1

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
Improve this question
6
  • You state that you loop across two sheets but you have this tagged as ms-access should it be excel instead? Where does ms-access come into play with this? Commented Feb 23, 2012 at 14:26
  • Yep, sorry. Been working in Access too much recently. Commented Feb 23, 2012 at 14:27
  • If you are used to using Access, have you considered using ADO and queries in Excel? Commented Feb 23, 2012 at 15:19
  • I actually had this data in Access and moved it to Excel to loop through cells. I've never used ADO before though. Commented Feb 23, 2012 at 15:20
  • Why did the comparison not work in Access? ADO (in this case) is just a means of using Excel as if it were a database, so you can use sheets and ranges as tables. Commented Feb 23, 2012 at 15:47

3 Answers 3

Reset to default
3

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
Improve this answer
Sign up to request clarification or add additional context in comments.

Comments

2

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
Improve this answer

4 Comments

Good point, thanks. Do my Application.StatusBar calls slow anything down?
Most likely. You can always calculate the execution time with and without. Also, printing to your file might be faster in one go rather than one line at a time. See my edit.
Oh wow. Turning off StatusBar updates made it process 20 outer loops in 1 second as opposed to 5 minutes with StatusUpdate.
You could only update the StatusBar every n loops (if x mod 100 = 0 Then 'Do the update End If) for an update every 100 loops for example.
1

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.

Improve this answer

Comments

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.