Using InStr to Find Matches Between Columns

[ItsBeenALongTime]

Really stumped on this. What I'm trying to do is pretty simple. I have a master list of strings in a column in one Workbook ("Master List"). I am trying to match this against another list of strings in a different column in another Workbook ("wB").

What I want the code to do is look for partial matches using the INSTR function. It has to be INSTR because some of the strings in WB will have extra characters. For example, one of the strings in the Master List might be deborah. The string in a cell in wB might be deborah@hotmail.com. I want the code to identify this as a match.

If the code identifies a match I want it to copy the row where the match was found in wB and paste it into a Results sheet in the Master List Workbook. I want to copy the entire row. I also want to output some location metrics in the pasted row so that I can find the original data later, if needed.

I have the code working right now and I think it's pretty efficient, but the issue is that it's not quick enough. wB has over 700,000 rows and Master List has over 32,000 rows. As you can imagine, that leads to a lot of combinations to check. My code right now works by checking the respective ranges against each other. I have read online that checking arrays against each other is significantly faster (leading to a >90% reduction in time taken). I've also heard of something called Dictionaries, but I'm completely unaware of how those function.

Could someone help me transform my code right now into a version that uses arrays instead of ranges? It's been a long time since I learned VBA in college so I'm struggling with how to do this with arrays. The Code was Hanging so I had to throw a DoEvents into the loop to stop it from going ninto "Not Responding." I'm aware that's likely not a best practice, so would love to take it out if I can.

Option Explicit

Sub MatchPhoneNumbers()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    'Define Variables
    Dim wB As Workbook, wS As Worksheet, Results As Worksheet, aFile As String
    Dim Cel As Range, Rng As Range
    Dim findStr As String, rw As Range, r As Long
    'Obtain Workbook to Check from User
    'Display a Dialog Box that allows to select a single file.

    With Application.FileDialog(msoFileDialogFilePicker)
        'Makes sure the user can select only one file
        .AllowMultiSelect = False
        'Filter to just the following types of files to narrow down selection options
        .Filters.Add "Excel Files", "*.xlsx; *.xlsm; *.xls; *.xlsb", 1
        'Show the dialog box
        'If user clicks "Cancel," exit code
        If .Show = -1 Then
            'Store in aFile variable
            aFile = .SelectedItems.Item(1)
        Else
            Exit Sub
        End If
    End With
    
    'Set paste row in Results sheet to store spot where left off
    r = ThisWorkbook.Sheets("Master List").Cells(8, 7).Value
    
    'Set Master List to Match Against
    With ThisWorkbook.Sheets("Master List")
        Set Rng = .Range("A3", .Range("a" & .Rows.Count).End(xlUp))
    End With
    'Create New Sheet to Output Results
    Set Results = ThisWorkbook.Sheets("Results")
    

    'Open Selected Workbook
    Set wB = Workbooks.Open(aFile)
    DoEvents
    'Go through every Worksheet in Workbook
    For Each wS In wB.Worksheets
        DoEvents
        'Go through every used row in Worksheet
        For Each rw In wS.UsedRange.Rows
            For Each Cel In Rng
                'Store each cell value in a variable
                findStr = Cel.Value
                'Check each cell value against contents of every cell in the row in the worksheet being checked
                If InStr(Cells(rw.Row, 6), findStr) > 0 Then
                    'If match was found, paste contents of row into new row in Results sheet
                    r = r + 1
                    rw.Copy Results.Cells(r, 1)
                    Results.Cells(r, "AA").Resize(, 5) = Array(Cel.Address(False, False), findStr, wB.Name, wS.Name, "Row " & rw.Row)
                End If
            'Continue Looping
            Next Cel
        Next rw
    Next

    wB.Close SaveChanges:=False
    DoEvents
    
    'Update to last pasted Results row
    ThisWorkbook.Sheets("Master List").Cells(8, 7).Value = r

  'Re-enable paused functions
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True
  Application.EnableEvents = True
  'Show completed
  MsgBox ("The Macro has finished. Please close this message box.")
End Sub

 

[Farscape2020]

Hi ItsBeenALongTime,

You could try readjusting your code with the following

Sub MatchPhoneNumbers()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    'Define Variables
    Dim masterArray As Variant
    Dim wBArray As Variant
    Dim wB As Workbook, wS As Worksheet, Results As Worksheet, aFile As String
    Dim resultsLastRow, i, j As Long
    'Obtain Workbook to Check from User
    'Display a Dialog Box that allows to select a single file.

    With Application.FileDialog(msoFileDialogFilePicker)
        'Makes sure the user can select only one file
        .AllowMultiSelect = False
        'Filter to just the following types of files to narrow down selection options
        .Filters.Add "Excel Files", "*.xlsx; *.xlsm; *.xls; *.xlsb", 1
        'Show the dialog box
        'If user clicks "Cancel," exit code
        If .Show = -1 Then
            'Store in aFile variable
            aFile = .SelectedItems.Item(1)
        Else
            Exit Sub
        End If
    End With
    
    'Set paste row in Results sheet to store spot where left off
'    r = ThisWorkbook.Sheets("Master List").Cells(8, 7).Value
    
    'Set Master List to Match Against
    masterArray = ThisWorkbook.Sheets("Master List").Range("A3:A" & ThisWorkbook.Sheets("Master List").Cells(Rows.Count, 1).End(xlUp).Row)

    'Create New Sheet to Output Results
    Set Results = ThisWorkbook.Sheets("Results")
    resultsLastRow = Results.Cells(Rows.Count, 1).End(xlUp).Row
    
    'Open Selected Workbook
    Set wB = Workbooks.Open(aFile)
    'Go through every Worksheet in Workbook

    For Each wS In wB.Worksheets
        DoEvents
        'Go through every used row in Worksheet
        wBArray = wS.Range("A1:A" & wS.Cells(Rows.Count, 1).End(xlUp).Row)
    
        For j = LBound(masterArray) To UBound(masterArray)
        
            For i = LBound(wBArray) To UBound(wBArray)
            
                If InStr(LCase(wBArray(i, 1)), LCase(masterArray(j, 1))) > 0 Then
                
                    wS.Rows(i).Copy Results.Rows(resultsLastRow)
                    resultsLastRow = resultsLastRow + 1
                End If
            
            Next i
    
        Next j
        
    Next wS


    wB.Close SaveChanges:=False
    
    'Update to last pasted Results row
    ThisWorkbook.Sheets("Master List").Cells(8, 7).Value = r

  'Re-enable paused functions
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True
  Application.EnableEvents = True
  'Show completed
  MsgBox ("The Macro has finished. Please close this message box.")
End Sub

Take Care