Solved: Add another sheet to the search

[Gil]

Hello

I need to add an additional sheet to the search code below ie Sheet3. So when the code runs it looks in Sheet2 then Sheet3 for the result.
Gil

[VBA]Private Sub Anotherexample_Click()
Dim lngLastRow As Long
' This loop runs the following code in column A
Dim Sh As Worksheet
Dim Fnd As Range
Dim c As Range
Dim FirstAddress As String
Dim SecAdd As String
Dim x As Long
Set Sh = Sheets("Sheet2")

Set c = Cells.Find(What:="LIC ", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False)
If Not c Is Nothing Then FirstAddress = c.Address
Do
x = 6
Set Fnd = Sh.Cells.Find((Split(c)(1)), LookAt:=xlWhole)
If Not Fnd Is Nothing Then
SecAdd = Fnd.Address
'Inner loop ***************
Do
With c.Offset(, x)
.Value = Sh.Cells(3, Fnd.Column - 0) & "-" & Fnd.Offset(, -1) & "-" & Fnd.Offset(, -2)
.Font.Bold = True
.Font.Color = -16776961
End With
Set Fnd = Sh.Cells.FindNext(Fnd)
x = x + 1
Loop While Not Fnd Is Nothing And Fnd.Address <> SecAdd
'******************************
Else
With c.Offset(, 6)
.Value = "Not found"
.Font.Bold = True
.Font.Color = -16776961
End With
End If
Set c = Cells.Find(What:="LIC ", After:=c, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False)
Loop While Not c Is Nothing And c.Address <> FirstAddress
End Sub[/VBA]

[mdmackillop]

Please post your own attempt to solve this. Remember, we are here to assist, not to do all the work.

[Gil]

Hello
I take your point. Am I going in the right direction by using

this line [vba]Set Sh = Sheets(Array("Sheet2", "Sheet3"))[/vba]
instead of [vba]Set Sh = Sheets("Sheet2")[/vba]
which stops with a Run-time error '13' Type mismatch

to go in

[vba]Private Sub Anotherexample_Click()
Dim lngLastRow As Long
' This loop runs the following code in column A
Dim Sh As Worksheet
Dim Fnd As Range
Dim c As Range
Dim FirstAddress As String
Dim SecAdd As String
Dim x As Long
Set Sh = Sheets(Array("Sheet2", "Sheet3"))
Set c = Cells.Find(What:="LIC ", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False)
If Not c Is Nothing Then FirstAddress = c.Address
Do
x = 6
Set Fnd = Sh.Cells.Find((Split(c)(1)), LookAt:=xlWhole)
If Not Fnd Is Nothing Then
SecAdd = Fnd.Address
'Inner loop ***************
Do
With c.Offset(, x)
.Value = Sh.Cells(3, Fnd.Column - 0) & "-" & Fnd.Offset(, -1) & "-" & Fnd.Offset(, -2)
.Font.Bold = True
.Font.Color = -16776961
End With
Set Fnd = Sh.Cells.FindNext(Fnd)
x = x + 1
Loop While Not Fnd Is Nothing And Fnd.Address <> SecAdd
'******************************
Else
With c.Offset(, 6)
.Value = "Not found"
.Font.Bold = True
.Font.Color = -16776961
End With
End If
Set c = Cells.Find(What:="LIC ", After:=c, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False)
Loop While Not c Is Nothing And c.Address <> FirstAddress
End Sub[/vba]

[Gil]

Sorry. I have to acknoledge that my understanding of VBA is way down the scale. Having tried umpteen things I get nothing that works. Having read through many codes both in VBA Express and the net the only solution I have found to work is to repeat the code and just changing Sheet2 to Sheet3. Crude as it may seem it works.
Gil

[mdmackillop]

Hi Gil,
Sorry for the delay.
You need to change the loop position so that X increases to show results from both sheets. I've added a line to note under the result the sheet where the result was found. This is not well tested, so if there are issues you can't fix, let us know.

[VBA]
Private Sub Anotherexample_Click()
Dim lngLastRow As Long
' This loop runs the following code in column A
Dim Sh
Dim Fnd As Range
Dim c As Range
Dim FirstAddress As String
Dim SecAdd As String
Dim x As Long
Dim arr, a
arr = (Array("Sheet2", "Sheet3"))

Set c = Cells.Find(What:="LIC ", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False)
If Not c Is Nothing Then FirstAddress = c.Address
Do
x = 6
For Each a In arr
Set Sh = Sheets(a)
Set Fnd = Sh.Cells.Find((Split(c)(1)), LookAt:=xlWhole)
If Not Fnd Is Nothing Then
SecAdd = Fnd.Address
'Inner loop ***************
Do
With c.Offset(, x)
.Offset(1) = Sh.Name
.Value = Sh.Cells(3, Fnd.Column - 0) & "-" & Fnd.Offset(, -1) & "-" & Fnd.Offset(, -2)
.Font.Bold = True
.Font.Color = -16776961
End With
Set Fnd = Sh.Cells.FindNext(Fnd)
x = x + 1
Loop While Not Fnd Is Nothing And Fnd.Address <> SecAdd
'******************************
Else
With c.Offset(, 6)
.Value = "Not found"
.Font.Bold = True
.Font.Color = -16776961
End With
End If
Set c = Cells.Find(What:="LIC ", After:=c, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False)
Next
Loop While Not c Is Nothing And c.Address <> FirstAddress
End Sub
[/VBA]

[mdmackillop]

There is an issue as I22 is being overwritten in this example, so a little reordering is required.

[Gil]

Hello mdmackillop
No need to appologise, all help is gratefully recieved. What you have supplied looks good and I am currently applying it to my project and testing it. If all is good I will mark it solved.
Many thanks again to you and VBA Express
Gil
p.s. I will make sure there are no add ons this time.

[mdmackillop]

Hi Gil
It is not 100% correct as the posted file shows. You should correct the bug before using the results.

[Gil]

Hello mdmackillop
Thanks for the heads up but which I22 are you refering to as at the moment I cant see the mud through the trees.
Gil

[mdmackillop]

Run the code with only Sheet2 in the array and you get 3 results in row 22. Add back Sheet3, and you will see that I22 gets overwritten. There should be 6 results.

[mdmackillop]

The incrementing value suited the single sheet scenario. for two or more sheets, it's easier to determine the target cell in each loop

[VBA]
Sub Anotherexample_Click()
Dim lngLastRow As Long
' This loop runs the following code in column A
Dim Sh
Dim Fnd As Range
Dim c As Range
Dim FirstAddress As String
Dim SecAdd As String
Dim x As Long
Dim arr, a
Columns("E:M").ClearContents
arr = (Array("Sheet2", "sheet3"))

Set c = Cells.Find(What:="LIC ", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False)
If Not c Is Nothing Then FirstAddress = c.Address
Do
For Each a In arr
Set Sh = Sheets(a)
Set Fnd = Sh.Cells.Find((Split(c)(1)), LookAt:=xlWhole)
If Not Fnd Is Nothing Then
SecAdd = Fnd.Address
'Inner loop ***************
Do
Set tgt = Cells(c.Row, Columns.Count).End(xlToLeft).Offset(, 1)
If tgt.Column < 6 Then Set tgt = Cells(c.Row, 8)
With tgt
.Offset(1) = Sh.Name
.Value = Sh.Cells(3, Fnd.Column - 0) & "-" & Fnd.Offset(, -1) & "-" & Fnd.Offset(, -2)
.Font.Bold = True
.Font.Color = -16776961
End With
Set Fnd = Sh.Cells.FindNext(Fnd)
Loop While Not Fnd Is Nothing And Fnd.Address <> SecAdd
'******************************
Else
Set tgt = Cells(c.Row, Columns.Count).End(xlToLeft).Offset(, 1)
If tgt.Column < 6 Then Set tgt = Cells(c.Row, 8)
With tgt
.Value = "Not found"
.Font.Bold = True
.Font.Color = -16776961
End With
End If
Set c = Cells.Find(What:="LIC ", After:=c, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, _
SearchFormat:=False)
Next
Loop While Not c Is Nothing And c.Address <> FirstAddress
End Sub
[/VBA]

[Gil]

Hello mdmackillop
Well spotted, I now see what you mean by the over write. Many thanks for the updated version which I am currently trying out.
Gil