Some more basic code for a common problem.
Code:
'===================================================
'- FIND MULTIPLE MATCHES IN ALL WORKSHEETS
'- EXAMPLE MACRO TO SEARCH ALL WORKSHEETS
'- AND RETURN DATA TO THE ACTIVE SHEET
'- Gets lookup value from cell A1
'- run this macro from that sheet.
'- change main routine for a different input method
'- and subroutine for different usage of found data
'- Brian Baulsom May 2005
'=====================================================
Dim ToSheet As Worksheet
Dim ws As Worksheet
Dim MyValue As String
Dim FoundCell As Object
Dim ToRow As Long
Dim FromRow As Long
Dim Counter As Integer
'===================================
'- MAIN ROUTINE
'===================================
Sub FIND_MATCHES_TO_CELL()
Set ToSheet = ActiveSheet
ToRow = 1
MyValue = ToSheet.Cells(ToRow, 1).Value
search_all_sheets
MsgBox ("Found " & Counter & " matches.")
End Sub
'= END OF PROCEDURE ======================================
'---------------------------------------------------------
'- subroutine
'---------------------------------------------------------
Private Sub search_all_sheets()
For Each ws In Worksheets
If ws.Name <> ActiveSheet.Name Then
'-look in column A
With ws.Columns(1).Cells
'---------------------------------------------
'- do search
Set FoundCell = .Find(MyValue, LookIn:=xlValues)
If Not FoundCell Is Nothing Then ' value found
FirstAddress = FoundCell.Address
FromRow = FoundCell.Row
Do
Counter = Counter + 1
'-------------------------------------
'- transfer values from columns B:C
For c = 2 To 3
ActiveSheet.Cells(ToRow, c).Value = _
ws.Cells(FromRow, c).Value
Next
'-------------------------------------
'- add sheet name to column D
ActiveSheet.Cells(ToRow, 4).Value = _
ws.Name
'-------------------------------------
'- find again
ToRow = ToRow + 1
Set FoundCell = .FindNext(FoundCell)
Loop While Not FoundCell Is Nothing And _
FoundCell.Address <> FirstAddress
'----------------------------------------
End If
End With
End If
Next
End Sub
