VBA - Find all matches across multiple sheets - vba

Question

I am working on a macro that will search an entire workbook for various codes. These codes are all six digit numbers. Codes I wish to search for are input in column A of a sheet called "Master". If a code found on another sheet matches one in Master it's sheet name and cell will be pasted in column B next to it's match in Master. When successful the end result looks like this.
The code posted below works in certain cases, but fails quite often. Occasionally a run-time error will appear, or an error message with "400" and nothing else. When these errors occur the macro fills a row with matches for a blank value at the end of all the listed codes. This is obviously not an intended function.
I am at a loss regarding the above error. I have wondered if limiting the search range would help stability. All codes on other sheets are only found in column A, so searching for matches in all columns as is done currently is quite wasteful. Speed is secondary to stability however, I first want to eliminate all points of failure.
Sub MasterFill()
Dim rngCell As Range
Dim rngCellLoc As Range
Dim ws As Worksheet
Dim lngLstRow As Long
Dim lngLstCol As Long
Dim strSearch As String
Sheets("Master").Select
lngLstRowLoc = Sheets("Master").UsedRange.Rows.Count
Application.ScreenUpdating = False
For Each rngCellLoc In Range("A1:A" & lngLstRowLoc)
i = 1
For Each ws In Worksheets
If ws.Name = "Master" Then GoTo SkipMe
lngLstRow = ws.UsedRange.Rows.Count
lngLstCol = ws.UsedRange.Columns.Count
ws.Select
For Each rngCell In Range(Cells(2, 1), Cells(lngLstRow, lngLstCol))
If InStr(rngCell.Value, rngCellLoc) > 0 Then
If rngCellLoc.Offset(0, i).Value = "" Then
rngCellLoc.Offset(0, i).Value = ws.Name & " " & rngCell.Address
i = i + 1
End If
End If
Next
SkipMe:
Next ws
Next
Application.ScreenUpdating = True
Worksheets("Master").Activate
MsgBox "All done!"
End Sub

Answer 1

See if this doesn't expedite matters while correcting the logic.
Sub MasterFill()
Dim addr As String, fndCell As Range
Dim rngCellLoc As Range
Dim ws As Worksheet
Application.ScreenUpdating = False
With Worksheets("Master")
For Each rngCellLoc In .Range(.Cells(1, "A"), .Cells(.Rows.Count, "A").End(xlUp))
For Each ws In Worksheets
If LCase(ws.Name) <> "master" Then
With ws.Columns("A")
Set fndCell = .Find(what:=rngCellLoc.Value2, After:=.Cells(1), _
LookIn:=xlFormulas, LookAt:=xlPart, _
MatchCase:=False, SearchFormat:=False)
If Not fndCell Is Nothing Then
addr = fndCell.Address(0, 0)
Do
With rngCellLoc
.Cells(1, .Parent.Columns.Count).End(xlToLeft).Offset(0, 1) = _
Join(Array(ws.Name, fndCell.Address(0, 0)), Chr(32))
End With
Set fndCell = .FindNext(After:=fndCell)
Loop While addr <> fndCell.Address(0, 0)
End If
End With
End If
Next ws
Next
.Activate
End With
Application.ScreenUpdating = True
MsgBox "All done!"
End Sub
I've used LookAt:=xlPart in keeping with your use of InStr for criteria logic; if you are only interested in whole cell values change this to LookAt:=xlWhole.
I've restricted the search range to column A in each worksheet.
Previous results are not cleared before adding new results.
Your own error was due to the behavior where a zero length string (blank or vbNullString) is found within any other string when determined by Instr.