Option Explicit
Sub SearchForMatches()
'https://www.mrexcel.com/board/threads/run-a-loop-in-master-file-and-find-match-in-files-located-in-another-folder.1159840/
'Examine many workboks for a row in Sheet1!A:A that matches an ID
'Copy row from seasrched file to right of ID
'No dupe IDs in a single file; may be dupes across multiple files
Dim sDataFilePath As String
Dim sIDSheetName As String
Dim sFileNameExt As String
Dim sID As String
Dim lLastIDRow As Long
Dim lIDIndex As Long
Dim rngCell As Range
Dim wks As Worksheet
Dim rngrngFoundCell As Range
Dim rngLastCell As Range
Dim sFirstAddr As String
Dim bNeedNewRow As Boolean
Dim sLoc As String
Dim wbk As Workbook
Dim oFound As Object
'Update next line to point to your data folder
sDataFilePath = "J:\Shared Documents\Programming\Mr Excel\SearchColumnOne\"
'Next line to hold worksheet name that holds IDs
sIDSheetName = "Worksheet 1"
ThisWorkbook.Activate
Sheets(sIDSheetName).Select
Sheets(sIDSheetName).AutoFilterMode = False
lLastIDRow = Cells(Rows.Count, 1).End(xlUp).Row
If lLastIDRow < 3 Then
MsgBox "No lookup values in " & sIDSheetName & " row A3 and down. Exiting."
GoTo End_Sub
End If
If Right(sDataFilePath, 1) <> "\" Then sDataFilePath = sDataFilePath & "\"
sFileNameExt = Dir(sDataFilePath & "*.xlsx")
Do While sFileNameExt <> vbNullString
Set wbk = Workbooks.Open(Filename:=sDataFilePath & sFileNameExt, ReadOnly:=True)
Set wks = wbk.Worksheets(1) 'Sheet that has data to check
wks.AutoFilterMode = False 'Make sure all lines visible
With ThisWorkbook.Sheets(sIDSheetName)
'Any line in code that starts with a . will be referring to the current ID sheet
lLastIDRow = .Cells(.Rows.Count, 1).End(xlUp).Row
'From bottom to top of ID sheet column 1
For lIDIndex = lLastIDRow To 3 Step -1
If .Cells(lIDIndex, 1).Value <> vbNullString Then
'Not a blank
sID = .Cells(lIDIndex, 1).Value 'save ID value
If .Cells(lIDIndex, 2).Value <> vbNullString Then bNeedNewRow = True 'Already data returned for that ID
'will have to add new row
Set oFound = wks.Range("A:A").Find(what:=sID, _
LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not oFound Is Nothing Then
'Found a match
If bNeedNewRow Then
'Insert blank row under filled ID row
.Rows(lIDIndex + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
End If
sLoc = wbk.Name & ", " & wks.Name & ", Row " & oFound.Row
.Cells(lIDIndex, 2).Value = sLoc
wks.Range(oFound, oFound.Offset(0, wks.Cells(oFound.Row, Columns.Count).End(xlToLeft).Column)).Copy _
Destination:=.Cells(lIDIndex + IIf(bNeedNewRow, 1, 0), 3)
With .Cells(lIDIndex + IIf(bNeedNewRow, 1, 0), 2)
If Not .Comment Is Nothing Then .ClearComments 'Clear comment if it exists
.AddComment
.Comment.Visible = False
.Comment.Text Text:=sLoc
End With
bNeedNewRow = False
End If 'Not oFound Is Nothing
End If '.Cells(lIDIndex, 1).Value <> vbNullString
Next
End With
sFileNameExt = Dir
wbk.Close SaveChanges:=False
Loop
End_Sub:
End Sub