PDA

View Full Version : Solved: Add another sheet to the search



Gil
04-14-2010, 11:50 AM
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

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

mdmackillop
04-14-2010, 03:38 PM
Please post your own attempt to solve this. Remember, we are here to assist, not to do all the work.

Gil
04-15-2010, 03:09 AM
Hello
I take your point. Am I going in the right direction by using

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

to go in

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

Gil
04-17-2010, 07:55 AM
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
04-17-2010, 08:31 AM
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.


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

mdmackillop
04-17-2010, 08:40 AM
There is an issue as I22 is being overwritten in this example, so a little reordering is required.

Gil
04-18-2010, 04:07 AM
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
04-18-2010, 04:29 AM
Hi Gil
It is not 100% correct as the posted file shows. You should correct the bug before using the results.

Gil
04-18-2010, 08:09 AM
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
04-18-2010, 08:24 AM
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
04-18-2010, 11:19 AM
The incrementing value suited the single sheet scenario. for two or more sheets, it's easier to determine the target cell in each loop


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

Gil
04-19-2010, 03:37 AM
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