Improving efficiency with nested for loops & array comparisons

Question

I have a macro that loops across two sheets comparing words in each cell. The code works fine, but is there a way to improve the efficiency or speed of this? I manually used a for loop to compare the string arrays as well, as I didn't find any VBA functions to do this. I do have ScreenUpdating off, which seems to help a bit.

For i = 2 To maxMn 'loop 1
    Sheets("Sh1").Select
    Cells(i, 2).Select
    mnStr = Cells(i, 2).Value
    mnArr = Split(mnStr, " ")

    x = 2
    For x = 2 To maxNm 'loop 2
        numTotal = 0
        numMatches = 0
        Sheets("Sh2").Select
        Cells(x, 6).Select
        nameStr = Cells(x, 6).Value
        nameArr = Split(nameStr, " ")
        For Each mn In mnArr 'loop 3
            For Each nam In nameArr 'loop 4
                Application.StatusBar = "(#" & i & " Sh1) (#" & x & " Sh2): Comparing " & mn & " to " & nam
                If LCase(nam) = LCase(mn) Then
                    'MsgBox "Yes, '" & nam & "' equal to " & mn
                    numMatches = numMatches + 1
                Else
                    'MsgBox "No, '" & nam & "' does not equal " & mn
                End If
            Next nam '4: For Each nam In nameArr
            numTotal = numTotal + 1
        Next mn '3: For Each mn In mnArr
        If numTotal > 2 And numTotal > 0 And numMatches >= numTotal / 2 Then
            LogMsg = "(#" & i & " Sh1) (#" & x & " Sh2): |" & mnStr & "| - |" & nameStr & "| = " & numMatches & "/" & numTotal & " matches."
            Print #FileNum, LogMsg
            'MsgBox numMatches & " matches out of " & numTotal & " total."
        End If
    Next x '2: For x = 2 To maxNm
Next i '1: For i = 2 To maxMn

Answer 1

The first rule of improving efficiency is don't select or activate anything. With datasets of 300 and 200 rows respectively, your code took 13.5 minutes. Just removing the selects

    For i = 2 To maxMn 'loop 1
        'Sheets("Sh1").Select
        'Cells(i, 2).Select
        mnStr = Sheets("Sh1").Cells(i, 2).Value
        mnArr = Split(mnStr, " ")

        x = 2
        For x = 2 To maxNm 'loop 2
            numTotal = 0
            numMatches = 0
            'Sheets("Sh2").Select
            'Cells(x, 6).Select
            nameStr = Sheets("Sh2").Cells(x, 6).Value

cut the time to 154 seconds. The screen redrawing is the single biggest time sink. The below code runs in 2.18 seconds (5.6 seconds if you add a statusbar update - which you don't need if it only takes 2 seconds)

Sub CompareWords2()

    Dim vaNam As Variant, vaMn As Variant
    Dim i As Long, j As Long
    Dim vaSplitNam As Variant, vaSplitMn As Variant
    Dim colUnique As Collection
    Dim lWord As Long
    Dim sLog As String
    Dim lMatches As Long, lTotal As Long
    Dim sgStart As Single

    sgStart = Timer

    'Put both ranges in an array
    With ThisWorkbook.Sheets("Sh1")
        vaMn = .Range(.Cells(2, 2), .Cells(.Rows.Count, 2).End(xlUp)).Value
    End With

    With ThisWorkbook.Sheets("Sh2")
        vaNam = .Range(.Cells(2, 6), .Cells(.Rows.Count, 6).End(xlUp)).Value
    End With

    For i = LBound(vaMn, 1) To UBound(vaMn, 1)
        For j = LBound(vaNam, 1) To UBound(vaNam, 1)
            'put all the first words in a collection
            vaSplitMn = Split(vaMn(i, 1), Space(1))
            Set colUnique = New Collection
            For lWord = LBound(vaSplitMn) To UBound(vaSplitMn)
                colUnique.Add vaSplitMn(lWord), LCase(CStr(vaSplitMn(lWord)))
            Next lWord

            'add all the next words to the collection to remove duplicates
            vaSplitNam = Split(vaNam(j, 1), Space(1))
            For lWord = LBound(vaSplitNam) To UBound(vaSplitNam)
                On Error Resume Next
                    colUnique.Add vaSplitNam(lWord), LCase(CStr(vaSplitNam(lWord)))
                On Error GoTo 0
            Next lWord

            'Write to log
            lMatches = UBound(vaSplitMn) + UBound(vaSplitNam) + 2 - colUnique.Count
            lTotal = UBound(vaSplitMn) + 1
            If lMatches >= lTotal / 2 Then
                sLog = sLog & "(#" & i & " Sh1) (#" & j & " Sh2): |" & vaMn(i, 1) & "| - |" & vaNam(j, 1) & "| = "
                sLog = sLog & lMatches & "/" & lTotal & " matches." & vbNewLine
            End If
        Next j
    Next i

    'post total log all at once
    Open ThisWorkbook.Path & Application.PathSeparator & "CompareLog2.txt" For Output As #1
    Print #1, sLog
    Close #1

    Debug.Print Timer - sgStart

End Sub

Answer 2

Here is a list of pointers to make this more efficient

1. Do not access the cells within the loop. Assign the cells into an array variable using the vals = Range("A2").Resize(N,1).Value property and access the values with vals(i,j). In the end you can write the values back into the spread sheet with Range("A2").Resize(N,1).Value = vals
2. Do not write to a file line by line within the loop. Write to a string and then write the entire string into a file in one operation
3. Minimize the use changing the screen by writing to status bars and progress bars. Either turn off updates with Application.ScreenUpdating = False or just omit the code. If needed maybe only every 100'th iteration for example update the UI.

Look at this answer for an example on how to use .Value to read and write into multiple cells at the same time efficiently.

Answer 3

This site has good tips for performance improvement. In your case, avoid looping over the cells; instead, store the content in an array and loop over the array. That should improve performance significantly.

The beginning of your code would look like this (I have commented out your original code):

Dim sheet1 As Variant
Dim sheet2 As Variant

With Sheets("Sh1")
  sheet1 = .Range(.Cells(1, 2), .Cells(maxMn, 2))
End With
With Sheets("Sh2")
  sheet2 = .Range(.Cells(1, 6), .Cells(maxNm, 6))
End With

For i = 2 To maxMn 'loop 1
    'Sheets("Sh1").Select
    'Cells(i, 2).Select
    'mnStr = Cells(i, 2).Value
    mnStr = sheet1(i, 1)
    mnArr = Split(mnStr, " ")

    x = 2
    For x = 2 To maxNm 'loop 2
        numTotal = 0
        numMatches = 0
        'Sheets("Sh2").Select
        'Cells(x, 6).Select
        'nameStr = Cells(x, 6).Value
        nameStr = sheet2(x, 1)
        nameArr = Split(nameStr, " ")
        For Each mn In mnArr 'loop 3

You could probably improve the file output too:

Dim i As Long
Dim fileName As String
Dim fileContent As String

i = FreeFile
fileName = "xxxxxx"
fileContent = "yyyyyyy" 'you can call your main function here and return a string
If Dir(fileName) <> "" Then Kill (fileName) 'If you want to override existing file
Open fileName For Binary Lock Read Write As #i
Put #i, , fileContent