List found strings on sheet

[L. Howard]

This snippet displays the found search strings in a message box - Sheet and cell address.

How do I get the last line to put the found strings in individual cells on the sheet instead of all in K2 as it now does.

Thanks,
Howard


If bFoundID Then
sMsg = "The ID (" & sID & ") was found on the following sheets:"
sMsg = sMsg & vbLf & vbLf
sMsg = sMsg & Join(Split(Mid(sIdShts, 2), ","), vbLf)
Else
sMsg = "ID not found"
End If
MsgBox sMsg

Range("K2") = Join(Split(Mid(sIdShts, 2), ","))

 

[GS]

This snippet displays the found search strings in a message box -

Sheet and cell address.

How do I get the last line to put the found strings in individual
cells on the sheet instead of all in K2 as it now does.

Thanks,
Howard


If bFoundID Then
sMsg = "The ID (" & sID & ") was found on the following sheets:"
sMsg = sMsg & vbLf & vbLf
sMsg = sMsg & Join(Split(Mid(sIdShts, 2), ","), vbLf)
Else
sMsg = "ID not found"
End If
MsgBox sMsg

Range("K2") = Join(Split(Mid(sIdShts, 2), ","))

While I fully understand what this code is doing.., I do not understand
the 'why' when you want to output to a range of cells. It would make
more sense to load the found IDs into an array, then 'dump' the array
into the worksheet.

As is, you could 'Split' sIdShts into a variant, then resize the target
cell...

vDataOut = Split(Mid(sIdShts, 2), ",")
Range("K2").Resize(1, lbound(vDataOut) + 1) = vDataOut

OR

Range("K2").Resize(lbound(vDataOut) + 1, 1) = _
Application.Transpose(vDataOut)

--
Garry

Free usenet access at http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion

 

[GS]

Oops..!

vDataOut = Split(Mid(sIdShts, 2), ",")
Range("K2").Resize(1, UBound(vDataOut) + 1) = vDataOut

OR

Range("K2").Resize(UBound(vDataOut) + 1, 1) = _
Application.Transpose(vDataOut)

--
Garry

Free usenet access at http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion

 

[L. Howard]

Hi Garry,

Here is the whole macro, which is an enhanced version by you of something Iwrote.

To start I just wanted it to list the found strings sheet and cell address on the summary sheet with (or without) the message box.

Where the final goal is to use a list on summary sheet (instead of an inputbox) that holds a number of search strings and take them one at a time anddo the workbook search for each search string making a list of the sheets each search string was found on.

abc123 sheets 3, 6, 9
qwe456 sheets 2, 4, 6, 7
www987 "not found"

So the array caper looks like the way to go where the search strings are read into an array and the found string sheets names are into another and then dumped onto the summary sheet as a list.

If that make sense to you then I will give that a go to see if I can put ittogether, and if I get hung up, will post back for some guidance.

Howard

Sub FindSheetsWithID()
'/ my code polished by Garry
' Looks for an ID on all sheets except "Sheet1",
' and Msgbox the result of the search.

Dim ws As Worksheet, Rng As Range
Dim sID$, sIdShts$, sMsg$, vDataOut$
Dim bFoundID As Boolean

sID = InputBox("Enter a Client ID numbet")
If Trim(sID) = "" Then Exit Sub

For Each ws In ThisWorkbook.Worksheets
If Not ws.Name = "Sheet1" Then
Set Rng = ws.UsedRange.Find(What:=sID, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns)
If Not Rng Is Nothing Then
bFoundID = True

sIdShts = sIdShts & ",'" & ws.Name & "'!" & Rng.Address

End If
End If
Next ws

If bFoundID Then
sMsg = "The ID (" & sID & ") was found on the following sheets:"
sMsg = sMsg & vbLf & vbLf
sMsg = sMsg & Join(Split(Mid(sIdShts, 2), ","), vbLf)
Else
sMsg = "ID not found"
End If

MsgBox sMsg
End Sub

 

[Claus Busch]

Hi Howard,

Am Wed, 25 Jun 2014 17:55:55 -0700 (PDT) schrieb L. Howard:

How do I get the last line to put the found strings in individual cells on the sheet instead of all in K2 as it now does.

write the matches in an array at once.
Try following code. The matches will be written in Sheet(1).

Sub FindSheetsWithID()

Dim wsh As Worksheet, c As Range
Dim strID As String, FirstAddress As String
Dim arrIn() As Variant, arrOut As Variant, myDic As Object
Dim n As Long, i As Long, LRow As Long

strID = InputBox("Enter a Client ID numbet")
If Trim(strID) = "" Then Exit Sub

For Each wsh In ThisWorkbook.Sheets
If Not wsh.Name = "Sheet1" Then
Set c = wsh.UsedRange.Find(What:=strID, _
LookIn:=xlValues, _
LookAt:=xlWhole)
If Not c Is Nothing Then
FirstAddress = c.Address
Do
ReDim Preserve arrIn(n)
arrIn(n) = wsh.Name
n = n + 1
Set c = wsh.UsedRange.FindNext(c)
Loop While Not c Is Nothing And c.Address <> FirstAddress
End If
End If
Next

If n > 0 Then
Set myDic = CreateObject("Scripting.Dictionary")
For i = LBound(arrIn) To UBound(arrIn)
myDic(arrIn(i)) = arrIn(i)
Next
arrOut = myDic.items
End If


With Sheets(1)
LRow = .Cells(Rows.Count, "A").End(xlUp).Row
If n > 0 Then
.Range("A" & LRow + 1) = strID
.Range("B" & LRow + 1).Resize(columnsize:=myDic.Count) = arrOut
Else
.Range("A" & LRow + 1) = strID
.Range("B" & LRow + 1) = "Not found"
End If
End With

End Sub


Regards
Claus B.

 

[Claus Busch]

Hi Howard,

Am Thu, 26 Jun 2014 08:17:15 +0200 schrieb Claus Busch:

write the matches in an array at once.
Try following code. The matches will be written in Sheet(1).

better try:

Sub FindSheetsWithID()

Dim wsh As Worksheet, c As Range
Dim strID As String, FirstAddress As String, strOut As String
Dim arrIn() As Variant, arrOut As Variant, myDic As Object
Dim n As Long, i As Long, LRow As Long

strID = InputBox("Enter a Client ID numbet")
If Trim(strID) = "" Then Exit Sub

For Each wsh In ThisWorkbook.Sheets
If Not wsh.Name = "Sheet1" Then
Set c = wsh.UsedRange.Find(What:=strID, _
LookIn:=xlValues, _
LookAt:=xlWhole)
If Not c Is Nothing Then
FirstAddress = c.Address
Do
ReDim Preserve arrIn(n)
arrIn(n) = Replace(wsh.Name, "Sheet", "")
n = n + 1
Set c = wsh.UsedRange.FindNext(c)
Loop While Not c Is Nothing And c.Address <> FirstAddress
End If
End If
Next

If n > 0 Then
Set myDic = CreateObject("Scripting.Dictionary")
For i = LBound(arrIn) To UBound(arrIn)
myDic(arrIn(i)) = arrIn(i)
Next
arrOut = myDic.items
strOut = Join(arrOut, ",")
End If


With Sheets(1)
LRow = .Cells(Rows.Count, "A").End(xlUp).Row
If n > 0 Then
.Range("A" & LRow + 1) = strID
.Range("B" & LRow + 1) = strOut
Else
.Range("A" & LRow + 1) = strID
.Range("B" & LRow + 1) = "Not found"
End If
End With

End Sub


Regards
Claus B.

 

[L. Howard]

Regards

Claus B.

--

Thanks Claus, that is a nice jump start.

Howard

 

[GS]

Here is the whole macro, which is an enhanced version by you of

something I wrote.

To start I just wanted it to list the found strings sheet and cell
address on the summary sheet with (or without) the message box.

Yes, I recall this! There was no intent to write to a worksheet and so
makes sense that there's no reason to build an output array. Now that
your intent has changed.., so must the code to suit. Claus has replied
with a good example of how to do it! (Though I'm curious about the use
of Scripting.Dictionary)

--
Garry

Free usenet access at http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion

 

[Claus Busch]

Am Thu, 26 Jun 2014 03:20:39 -0400 schrieb GS:

Yes, I recall this! There was no intent to write to a worksheet and so
makes sense that there's no reason to build an output array. Now that
your intent has changed.., so must the code to suit. Claus has replied
with a good example of how to do it! (Though I'm curious about the use
of Scripting.Dictionary)

Regards
Claus B.

 

[Claus Busch]

Hi Garry,

Am Thu, 26 Jun 2014 03:20:39 -0400 schrieb GS:

Though I'm curious about the use of Scripting.Dictionary

to avoid the output like 2,2,2,3,3,3,3,3,4if he has more than one match
in a sheet.
With Scripting.Dictionary he get unique values and the output is
2,3,4


Regards
Claus B.

 

[GS]

Hi Garry,

Am Thu, 26 Jun 2014 03:20:39 -0400 schrieb GS:


to avoid the output like 2,2,2,3,3,3,3,3,4if he has more than one
match in a sheet.
With Scripting.Dictionary he get unique values and the output is
2,3,4


Regards
Claus B.

Yes, I understand. I thought the IDs were already a unique list and so
duplicates are not an issue. Though I suppose more than 1 instance of
any ID is possible. I might be inclined to go with building a string
conditional on found IDs not already InStr(), then Split to an output
array as I exampled (2nd post). Your way might be faster, though,
because building a conditional string tests every found ID before
adding it!<g>

--
Garry

Free usenet access at http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion

 

[Claus Busch]

Hi Garry, hi Howard,

Am Thu, 26 Jun 2014 09:26:42 +0200 schrieb Claus Busch:

to avoid the output like 2,2,2,3,3,3,3,3,4if he has more than one match
in a sheet.
With Scripting.Dictionary he get unique values and the output is
2,3,4

oops, if I don't use FindNext I don'T have to create unique values.

Better try:

Sub FindSheetsWithID()

Dim wsh As Worksheet, c As Range
Dim strID As String, strOut As String
Dim LRow As Long

strID = InputBox("Enter a Client ID numbet")
If Trim(strID) = "" Then Exit Sub

For Each wsh In ThisWorkbook.Sheets
If Not wsh.Name = "Sheet1" Then
Set c = wsh.UsedRange.Find(What:=strID, _
LookIn:=xlValues, _
LookAt:=xlWhole)
If Not c Is Nothing Then
strOut = strOut & wsh.Index & ", "
End If
End If
Next

With Sheets(1)
LRow = .Cells(Rows.Count, "A").End(xlUp).Row
If Len(strOut) > 0 Then
.Range("A" & LRow + 1) = strID
.Range("B" & LRow + 1) = Left(strOut, Len(strOut) - 2)
Else
.Range("A" & LRow + 1) = strID
.Range("B" & LRow + 1) = "Not found"
End If
End With

End Sub


Regards
Claus B.

 

[GS]

oops, if I don't use FindNext I don'T have to create unique values.

Yes, that's better so long as the number found per ID doesn't matter.
(I initially didn't think there needed to be FindNext once found)

--
Garry

Free usenet access at http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion

 

[L. Howard]

Hi Claus, Garry,

Here is as far as I have gotten, which will correctly return only the first strID on the first sheet looked at(Sheet 2, column G, G2).

This only worked after I commented out the "Set c...FindNext" which was throwing an error.

Some additional info of what I am shooting for.

Each of the two sheets in the array have a list in column G.

I want to go down that list on sheet 2 and post the returns on sheet "Instructions", then go down the list on sheet 3, column G and post the return on sheet "Instructions".

I am only using two sheets, but there may be around ten sheets + / - in real life.

My posted code here is modified from your first code suggestion. And I notice the Find Next is also in that commented out line.

I'll take a look at the second code, maybe I can make it return more than just one strID.

Howard


Sub ListSheetsWithstrID()

Dim wsh As Worksheet, c As Range, rngG As Range, strID As Range

Dim FirstAddress As String, strOut As String

Dim arrIn() As Variant, arrOut As Variant, myDic As Object

Dim n As Long, i As Long, j As Long, LRow As Long

Dim MyArr As Variant

MyArr = Array("Sheet2", "Sheet3")

Application.ScreenUpdating = False

For j = LBound(MyArr) To UBound(MyArr)

With Sheets(MyArr(i))

Set rngG = .Range("G2:G" & Cells(Rows.Count, 7).End(xlUp).Row)

For Each c In rngG

For Each wsh In ThisWorkbook.Sheets

If Not wsh.Name = "Instructions" Then

Set strID = wsh.UsedRange.Find(What:=c, _
LookIn:=xlValues, _
LookAt:=xlWhole)

If Not c Is Nothing Then

FirstAddress = c.Address

Do

ReDim Preserve arrIn(n)

arrIn(n) = Replace(wsh.Name, "Sheet", "")

n = n + 1

'Set c = wsh.UsedRange.FindNext(c)

Loop While Not c Is Nothing And c.Address <> FirstAddress

End If ' not c

End If ' not wsh.name

Next ' wsh

Next ' c

End With ' myArr

Next 'j

If n > 0 Then
Set myDic = CreateObject("Scripting.Dictionary")
For i = LBound(arrIn) To UBound(arrIn)
myDic(arrIn(i)) = arrIn(i)
Next ' i
arrOut = myDic.items

strOut = Join(arrOut, ",")

End If

With Sheets("Instructions") 'Sheets(1)
LRow = .Cells(Rows.Count, "A").End(xlUp).Row

If n > 0 Then
.Range("A" & LRow + 1) = strID
.Range("B" & LRow + 1) = strOut
Else
.Range("A" & LRow + 1) = strID
.Range("B" & LRow + 1) = "Not found"
End If

End With

End Sub

 

[Claus Busch]

Hi Howard,

Am Thu, 26 Jun 2014 04:01:54 -0700 (PDT) schrieb L. Howard:

Each of the two sheets in the array have a list in column G.

I want to go down that list on sheet 2 and post the returns on sheet "Instructions", then go down the list on sheet 3, column G and post the return on sheet "Instructions".

I am only using two sheets, but there may be around ten sheets + / - in real life.

what output do you expect? The match address?
Then try:

Sub FindSheetsWithID()

Dim wsh As Worksheet, c As Range
Dim strID As String, FirstAddress As String, strOut As String
Dim LRow As Long, i As Long
Dim StrShN As String
Dim myArr As Variant

strID = InputBox("Enter a Client ID numbet")
If Trim(strID) = "" Then Exit Sub

myArr = Array("Sheet2", "Sheet3")
For i = LBound(myArr) To UBound(myArr)
With Sheets(myArr(i))
strOut = ""
StrShN = .Name
Set c = .Range("G:G").Find(What:=strID, _
LookIn:=xlValues, _
LookAt:=xlWhole)
If Not c Is Nothing Then
FirstAddress = c.Address
Do
If strOut = "" Then
strOut = StrShN & " " & c.Address(0, 0) & ", "
Else
strOut = strOut & c.Address(0, 0) & ", "
End If
Set c = .Range("G:G").FindNext(c)
Loop While Not c Is Nothing And c.Address <> FirstAddress
End If
End With

With Sheets("Instructions")
LRow = .Cells(Rows.Count, "A").End(xlUp).Row
If Len(strOut) > Len(StrShN) Then
.Range("A" & LRow + 1) = strID
.Range("B" & LRow + 1) = Left(strOut, Len(strOut) - 2)
Else
.Range("A" & LRow + 1) = strID
.Range("B" & LRow + 1) = StrShN & " Not found"
End If
End With
Next
End Sub


Regards
Claus B.

 

[L. Howard]

what output do you expect? The match address?

Hi Claus,

I want to eliminate the InPutBox and have the code go to column G on each sheet in turn and process each sheets column G entries with the return to be like this:

Column G entries examples:

abc123
def456
ghi789

And the Instructions sheet returns like this:

abc123 2, 3
def456 3
ghi789 Not Found

Where:
abc123 was found on sheet2 and sheet3.
def456 was found only on sheet3.
ghi789 was not on any sheet.

The number of times abc123 etc. occurs on any sheet does not matter, just what sheet it was found on.

Howard

 

[GS]

I'm not following the logic of returning c.Address! This approach makes
more sense to me...


Option Explicit

Sub FindSheetsWithID_2()
' Looks for an ID on all sheets with search tag,
' and outputs results to summary sheet named "Instructions".

Dim Wks As Worksheet, wksTarget As Worksheet, rng As Range
Dim sID$, sOut$, sAddr1$
Dim bFoundID As Boolean, lCount&, vDataOut

sID = InputBox("Enter a Client ID")
If Trim(sID) = "" Then Exit Sub

'If we got here then initialize sOut
sOut = sID

On Error GoTo Cleanup
Set wksTarget = ThisWorkbook.Sheets("Instructions")
wksTarget.Activate

For Each Wks In ThisWorkbook.Worksheets
'Comment out next line to include all sheets
If bNameExists("MyTag", Wks) Then

sOut = sOut & "," & Wks.Name & "=": sAddr1 = ""
With Wks.Range("G:G")
Set rng = .Find(What:=sID, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByColumns)
If Not rng Is Nothing Then
sAddr1 = rng.Address
End If
Do
lCount = lCount + 1: Set rng = .FindNext(rng)
Loop While Not rng Is Nothing And rng.Address <> sAddr1
End With 'Wks.Range("G:G")
sOut = sOut & lCount: lCount = 0

'Comment out next line to include all sheets
End If 'bNameExists
Next 'Wks

'Output to worksheet
vDataOut = Split(sOut, ",")
'Next line assumes 1st row contains headings,
'or data already exists.
With wksTarget.Cells(Rows.Count, "A").End(xlUp)(2)
.Resize(1, UBound(vDataOut) + 1) = vDataOut
End With

Cleanup:
Set wksTarget = Nothing: Set rng = Nothing
End Sub

Function bNameExists(sName$, Wks As Worksheet) As Boolean
' Checks if sName exists in oSource
' Arguments:
' sName The defined name to check for
' oSource A ref to the Wkb or Wks being checked
' Returns:
' True if name exists

Dim x As Object
On Error Resume Next
Set x = Wks.Names(sName): bNameExists = (Err = 0)
End Function

--
Garry

Free usenet access at http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion

 

[Claus Busch]

Hi Howard,

Am Thu, 26 Jun 2014 09:16:10 -0700 (PDT) schrieb L. Howard:

I want to eliminate the InPutBox and have the code go to column G on each sheet in turn and process each sheets column G entries with the return to be like this:

the write the IDs in an array.
Try:

Sub FindSheetsWithID()
Dim c As Range
Dim strID As String, strOut As String
Dim LRow As Long, i As Long, j As Long
Dim myArr As Variant, arrID As Variant

strID = "abc123,def456,ghi789"
arrID = Split(strID, ",")

myArr = Array("Sheet2", "Sheet3")
For j = LBound(arrID) To UBound(arrID)
strOut = ""
For i = LBound(myArr) To UBound(myArr)
With Sheets(myArr(i))
Set c = .Range("G:G").Find(What:=arrID(j), _
LookIn:=xlValues, _
LookAt:=xlWhole)
If Not c Is Nothing Then
strOut = strOut & Replace(Sheets(myArr(i)).Name,
"Sheet", "") & ", "
Set c = .Range("G:G").FindNext(c)
End If
End With
Next

With Sheets("Instructions")
LRow = .Cells(Rows.Count, "A").End(xlUp).Row
If Len(strOut) > 0 Then
.Range("A" & LRow + 1) = arrID(j)
.Range("B" & LRow + 1) = Left(strOut, Len(strOut) - 2)
Else
.Range("A" & LRow + 1) = arrID(j)
.Range("B" & LRow + 1) = "Not found"
End If
End With
Next
End Sub


Regards
Claus B.

 

[GS]

How/where does code find/get the IDs?

--
Garry

Free usenet access at http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion

 

[GS]

Better...



Sub FindSheetsWithID_v3()
' Looks for an ID on all sheets with search tag,
' and outputs results to summary sheet named "Instructions".
' Note: The search tag is a local scope defined name range
' that contains the search data column address.

Dim Wks As Worksheet, wksTarget As Worksheet, rng As Range
Dim sID$, sOut$, sAddr1$
Dim bFoundID As Boolean, lCount&, vDataOut

sID = InputBox("Enter a Client ID")
If Trim(sID) = "" Then Exit Sub

'If we got here then initialize sOut
sOut = sID

On Error GoTo Cleanup
Set wksTarget = ThisWorkbook.Sheets("Instructions")
wksTarget.Activate

For Each Wks In ThisWorkbook.Worksheets
'Comment out next line to include all sheets
If bNameExists("MyTag", Wks) Then
sOut = sOut & "," & Wks.Name & "=": sAddr1 = ""
With Wks.Range("MyTag")
Set rng = .Find(What:=sID, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByColumns)
If Not rng Is Nothing Then
sAddr1 = rng.Address: bFoundID = True
End If
If bFoundID Then
Do
lCount = lCount + 1: Set rng = .FindNext(rng)
Loop While Not rng Is Nothing And rng.Address <> sAddr1
End If 'bFoundID
End With 'Wks.Range("G:G")
sOut = sOut & lCount: lCount = 0

'Comment out next line to include all sheets
End If 'bNameExists
Next 'Wks

'Output to worksheet
vDataOut = Split(sOut, ",")
'Next line assumes 1st row contains headings,
'or data already exists.
With wksTarget.Cells(Rows.Count, "A").End(xlUp)(2)
.Resize(1, UBound(vDataOut) + 1) = vDataOut
End With

Cleanup:
Set wksTarget = Nothing: Set rng = Nothing
End Sub

--
Garry

Free usenet access at http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion