Run a loop in Master file and find match in files located in another folder

[epoiezam]

Hi Guys

Need some help here,

Looking to automate my daily task using VBA.

Got this master file with list of customer's id (column A - Alphanumeric). What I'm trying to do is to run a code from the master file which will :-

1) Loop Master file - column A starting from cell A3 and try to find a match from a bunch of Data files located in a different folder.
2) When there's a match, VBA will copy & paste the whole row from Data to the Master (paste in B3)
3) Loop will continue with next row A4, A5 and so on until cell value =equals blank

Thanks in advance, really hope there's something to make my work easier.

 

[pbornemeier]

What worksheet on Loop Master File holds the text you are trying to match?
Where in "bunch of Data files located in a different folder" is the data you want to match? Can it be on any column in any worksheet in any of the "bunch of Data files located in a different folder"?
Are the data files Excel files? Do they contain any code? Can there be more than one match in one of those files? Can there be more than one match in multiple files?

 

[epoiezam]

Hi pbornemeier, thanks for responding. Truly appreciate it.

What worksheet on Loop Master File holds the text you are trying to match?
Worksheet 1 - Column A1
Where in "bunch of Data files located in a different folder" is the data you want to match?
No. all data files are located in one specific folder
Can it be on any column in any worksheet in any of the "bunch of Data files located in a different folder"?
No. Only in column A1
Are the data files Excel files?
Yes. xlsx
Do they contain any code?
No codes, just plain alphanumeric
Can there be more than one match in one of those files?
Within the same file. No
Can there be more than one match in multiple files?
In multiple files. Yes. There is a possibility.

 

[pbornemeier]

If there is a match in multiple files, do you want the line copied from each file? Or do you just want to find the first one?
Insert rows in Loop Master file and copy the second & subsequent ?
Do you also want the name of the file it was copied from somewhere? Perhaps filename in B3 and data starting in C3.
Do the workbooks that are being checked have more than one worksheet?
Does the match need to be case-sensitive?

 

[pbornemeier]

And/Or could include the filename in a comment in column B

 

[epoiezam]

1.If there is a match in multiple files, do you want the line copied from each file? Or do you just want to find the first one?
For each file, that would be nice.
2.Insert rows in Loop Master file and copy the second & subsequent ?
Yes please
3.Do you also want the name of the file it was copied from somewhere? Perhaps filename in B3 and data starting in C3.
Yes. To make it easier to find the source data
4.Do the workbooks that are being checked have more than one worksheet?
Yes. But the required data will always be in Sheet1
5.Does the match need to be case-sensitive?
No
6.And/Or could include the filename in a comment in column B
Yes. That would be great

Thank you pbornemeier..

 

[pbornemeier]

Got sidetracked by work - will attempt to finish today.

 

[epoiezam]

Thank you so much pbornemeier. Truly appreciate it.

 

[pbornemeier]

Test this and let me know if any changes are needed

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

 

[epoiezam]

Wow, you did it pbornemeier. It works GREAT.. Just as I want it.

Hey man truly appreciate this. It will surely make my work much easier.

Fantastic Bro..