Compare two columns in an Excel spreadsheet

Question

I have a VBA code that compares values in two columns (Column A & B), which runs slow. Please advise me the changes to make it run fast

The below code works just fine, but is running slow. Please advise me on how to make it run fast

 Sub compare()
       Dim ListA As Range
       Dim ListB As Range
       Dim c As Range
       Call Unprotect
       Set ListA = Range("A2:A1048576")
       Set ListB = Range("B2:B1048576")

       Application.ScreenUpdating = False

       Range("C1").Value = "Files in A that are NOT in B"
       Range("D1").Value = "Files in B that are Not in A"
       Range("E1").Value = "Matching Files"


       For Each c In ListA
       If Application.CountIf(ListB, c) = 0 Then
       Cells(Cells(Rows.Count, "C").End(xlUp).Row + 1, "C").Value = c
       End If
       Next c

       For Each c In ListA
       If Application.CountIf(ListB, c) >= 1 Then
       Cells(Cells(Rows.Count, "E").End(xlUp).Row + 1, "E").Value = c
       End If
       Next c

       For Each c In ListB
       If Application.CountIf(ListA, c) = 0 Then
       Cells(Cells(Rows.Count, "D").End(xlUp).Row + 1, "D").Value = c
       End If
       Next c



     Application.ScreenUpdating = True

     Call Protect
     End Sub

Any code changes to make the code run fast will be appreciated. Thanks

Answer 1

I'm sure you can further optimize the code, but this will definitely run faster.

It will run faster for a number of reasons, firstly I've combined one of your loops so you only have two For Loops, the second reason is that the code won't be looking at every cell in the worksheet, but it will find the last row with data and loop until then:

Sub compare()
    Dim ListA As Range
    Dim ListB As Range
    Dim c As Range
    Call Unprotect

    ListARange = Cells(Rows.Count, "A").End(xlUp).Row 'find the last row with data on column A
    ListBRange = Cells(Rows.Count, "B").End(xlUp).Row 'find the last row with data on column B

    Set ListA = Range("A2:A" & ListARange) 'set your range only until the last row with data
    Set ListB = Range("B2:B" & ListBRange)
    Application.ScreenUpdating = False

    Range("C1").Value = "Files in A that are NOT in B"
    Range("D1").Value = "Files in B that are Not in A"
    Range("E1").Value = "Matching Files"


    For Each c In ListA
        If Application.CountIf(ListB, c) = 0 Then
            Cells(Cells(Rows.Count, "C").End(xlUp).Row + 1, "C").Value = c
        ElseIf Application.CountIf(ListB, c) >= 1 Then
            Cells(Cells(Rows.Count, "E").End(xlUp).Row + 1, "E").Value = c
        End If
    Next c

    For Each c In ListB
        If Application.CountIf(ListA, c) = 0 Then Cells(Cells(Rows.Count, "D").End(xlUp).Row + 1, "D").Value = c
    Next c

    Application.ScreenUpdating = True

    Call Protect
End Sub

Answer 2

Using Dynamic Ranges (a Range that resizes to fit the actual data) will give you a huge performance boost.

Range("A2:A1048576") ' 1048575 cells

Range("A2", Range("A" & Rows.Count).End(xlUp)) 'All Cells between A1 and the last non-empty cell in Column A

Reading and writing to an Array is faster then working with the Cells themselves. Use Range.Value or Range.Value2 to return or write an Array of values from or to the target range. Range.Value2 is faster then Range.Value because it ignores formatting.

It is good practice to fully qualify your Ranges. In this way, your code will work as intended no matter what Worksheet or Workbook is active when the procedure is called.

With ThisWorkbook.Worksheets("Sheet1")
    Set listA = .Range("A2:A1048576")

Collections should be used when comparing two or more list. If you need to both a unique identifier (Key) and a reference (Value) then a Scripting.Dictionary is ideal. Scripting.Dictionary have built in methods to lookup values or object references stored in Key/Value pairs. Since the OP just need to lookup Keys, I used an ArrayList in my code.

Refactored Code

Sub Compare_By_Arraylist()
    Dim v As Variant
    Dim listA As Object, listNotA As Object, listMatches As Object
    Set listA = CreateObject("System.Collections.ArrayList")
    Set listNotA = CreateObject("System.Collections.ArrayList")
    Set listMatches = CreateObject("System.Collections.ArrayList")

    With ThisWorkbook.Worksheets("Sheet1")
        For Each v In .Range("A2", .Range("A" & .Rows.Count).End(xlUp)).Value2
            If Not listA.Contains(v) Then listA.Add v
        Next

        For Each v In .Range("B2", .Range("B" & .Rows.Count).End(xlUp)).Value2
            If listA.Contains(v) Then
                If Not listMatches.Contains(v) Then listMatches.Add v
            Else
                listNotA.Add v
            End If
        Next

        For Each v In .Range("B2", .Range("B" & .Rows.Count).End(xlUp)).Value2
            If listA.Contains(v) Then listA.Remove v
        Next

        Call UnProtect
        Application.ScreenUpdating = False
        .Range("C1:E1").Value = Array("Files in A that are NOT in B", "Files in B that are Not in A", "Matching Files")
        .Range("C2").Resize(listA.Count).Value = Application.WorksheetFunction.Transpose(listA.ToArray)
        .Range("D2").Resize(listNotA.Count).Value = Application.WorksheetFunction.Transpose(listNotA.ToArray)
        .Range("E2").Resize(listMatches.Count).Value = Application.WorksheetFunction.Transpose(listMatches.ToArray)
        Application.ScreenUpdating = True
        Call Protect

    End With


End Sub

Answer 3

Looping through the cells in a worksheet is slow. Better to bulk read the values into an array and process them then bulk write back to the worksheet.

The worksheet MATCH is faster than COUNTIF (see Is there a faster CountIF ) at counting and even faster if you only want to prove existence rather than a full count. Scripting dictionaries have their own indexed .Exists method but they do take time to load even from an array.

Option Explicit

Sub compareCOLs()
    Dim listA As Variant, listB As Variant, listC As Variant
    Dim a As Long, b As Long, c As Long, d As Long, e As Long

    With Worksheets("sheet2")
        listA = .Range(.Cells(2, "A"), .Cells(.Rows.Count, "A").End(xlUp)).Value2
        listB = .Range(.Cells(2, "B"), .Cells(.Rows.Count, "B").End(xlUp)).Value2
        ReDim listC(1 To (UBound(listA, 1) + UBound(listB, 1)), 1 To 3)

        'COUNTIF-style processing
        For a = LBound(listA, 1) To UBound(listA, 1)
            If IsError(Application.Match(listA(a, 1), listB, 0)) Then
                c = c + 1
                listC(c, 1) = listA(a, 1)
            Else
                e = e + 1
                listC(e, 3) = listA(a, 1)
            End If
        Next a
        For b = LBound(listB, 1) To UBound(listB, 1)
            If IsError(Application.Match(listB(b, 1), listA, 0)) Then
                d = d + 1
                listC(d, 2) = listB(b, 1)
            End If
        Next b

        'write results back to the worksheet
        .Cells(1, "C").Resize(1, 3) = Array("Files in A that are NOT in B", _
                                            "Files in B that are Not in A", _
                                            "Matching Files")
        .Cells(2, "C").Resize(UBound(listC, 1), UBound(listC, 2)) = listC
    End With
End Sub