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

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