Fast compare method of 2 columns

calendar_today Asked Oct 24, 2013
thumb_up 6 upvotes
history Updated April 16, 2026

Question posted 2013 ยท +8 upvotes

EDIT: Instead for my solution, use something like

 For i = 1 To tmpRngSrcMax
     If rngSrc(i) <> rngDes(i) Then ...
 Next i

It is about 100 times faster.

I have to compare two columns containing string data using VBA. This is my approach:

Set rngDes = wsDes.Range("A2:A" & wsDes.Cells(Rows.Count, 1).End(xlUp).Row)
Set rngSrc = wsSrc.Range("I3:I" & wsSrc.Cells(Rows.Count, 1).End(xlUp).Row)

tmpRngSrcMax = wsSrc.Cells(Rows.Count, 1).End(xlUp).Row
cntNewItems = 0

For Each x In rngSrc

tmpFound = Application.WorksheetFunction.CountIf(rngDes, x.Row)
Application.StatusBar = "Processed: " & x.Row & " of " & tmpRngSrcMax & " / " & Format(x.Row / tmpRngSrcMax, "Percent")
DoEvents ' keeps Excel away from the "Not responding" state

If tmpFound = 0 Then ' new item
    cntNewItems = cntNewItems + 1

    tmpLastRow = wsDes.Cells(Rows.Count, 1).End(xlUp).Row + 1  ' first empty row on target sheet
    wsDes.Cells(tmpLastRow, 1) = wsSrc.Cells(x.Row, 9)
End If
Next x

So, I’m using a For Each loop to iterate trough the 1st (src) column, and the CountIf method to check if the item is already present in the 2nd (des) column. If not, copy to the end of the 1st (src) column.

The code works, but on my machine it takes ~200s given columns with around 7000 rows. I noticed that CountIf works way faster when used directly as a formula.

Does anyone has ideas for code optimization?

Accepted answer +6 upvotes

Ok. Let’s clarify a few things.

So column A has 10,000 randomly generated values , column I has 5000 randomly generated values. It looks like this

enter image description here

I have run 3 different codes against 10,000 cells.

the for i = 1 to ... for j = 1 to ... approach, the one you are suggesting

Sub ForLoop()

Application.ScreenUpdating = False

    Dim stNow As Date
    stNow = Now

    Dim lastA As Long
    lastA = Range("A" & Rows.Count).End(xlUp).Row

    Dim lastB As Long
    lastB = Range("I" & Rows.Count).End(xlUp).Row

    Dim match As Boolean

    Dim i As Long, j As Long
    Dim r1 As Range, r2 As Range
    For i = 2 To lastA
        Set r1 = Range("A" & i)
        match = False
        For j = 3 To lastB
            Set r2 = Range("I" & j)
            If r1 = r2 Then
                match = True
            End If
        Next j
        If Not match Then
            Range("I" & Range("I" & Rows.Count).End(xlUp).Row + 1) = r1
        End If
    Next i

    Debug.Print DateDiff("s", stNow, Now)
Application.ScreenUpdating = True
End Sub

Sid’s appraoch

Sub Sample()
    Dim wsDes As Worksheet, wsSrc As Worksheet
    Dim rngDes As Range, rngSrc As Range
    Dim DesLRow As Long, SrcLRow As Long
    Dim i As Long, j As Long, n As Long
    Dim DesArray, SrcArray, TempAr() As String
    Dim boolFound As Boolean

    Set wsDes = ThisWorkbook.Sheets("Sheet1")
    Set wsSrc = ThisWorkbook.Sheets("Sheet2")

    DesLRow = wsDes.Cells(Rows.Count, 1).End(xlUp).Row
    SrcLRow = wsSrc.Cells(Rows.Count, 1).End(xlUp).Row

    Set rngDes = wsDes.Range("A2:A" & DesLRow)
    Set rngSrc = wsSrc.Range("I3:I" & SrcLRow)

    DesArray = rngDes.Value
    SrcArray = rngSrc.Value

    For i = LBound(SrcArray) To UBound(SrcArray)
        For j = LBound(DesArray) To UBound(DesArray)
            If SrcArray(i, 1) = DesArray(j, 1) Then
                boolFound = True
                Exit For
            End If
        Next j

        If boolFound = False Then
            ReDim Preserve TempAr(n)
            TempAr(n) = SrcArray(i, 1)
            n = n + 1
        Else
            boolFound = False
        End If
    Next i

    wsDes.Cells(DesLRow + 1, 1).Resize(UBound(TempAr) + 1, 1).Value = _
    Application.Transpose(TempAr)
End Sub

my (mehow) approach

Sub Main()
Application.ScreenUpdating = False

    Dim stNow As Date
    stNow = Now

    Dim arr As Variant
    arr = Range("A3:A" & Range("A" & Rows.Count).End(xlUp).Row).Value

    Dim varr As Variant
    varr = Range("I3:I" & Range("I" & Rows.Count).End(xlUp).Row).Value

    Dim x, y, match As Boolean
    For Each x In arr
        match = False
        For Each y In varr
            If x = y Then match = True
        Next y
        If Not match Then
            Range("I" & Range("I" & Rows.Count).End(xlUp).Row + 1) = x
        End If
    Next

    Debug.Print DateDiff("s", stNow, Now)
Application.ScreenUpdating = True
End Sub

the results as follows

enter image description here

now, you select the fast compare method ๐Ÿ™‚


filling in of the random values

Sub FillRandom()
    Cells.ClearContents
    Range("A1") = "Column A"
    Range("I2") = "Column I"

    Dim i As Long
    For i = 2 To 10002
        Range("A" & i) = Int((10002 - 2 + 1) * Rnd + 2)
        If i < 5000 Then
            Range("I" & Range("I" & Rows.Count).End(xlUp).Row + 1) = _ 
                 Int((10002 - 2 + 1) * Rnd + 2)
        End If
    Next i

End Sub

4 code variants in this answer

  • Variant 1 โ€” 34 lines, starts with Sub ForLoop()
  • Variant 2 โ€” 40 lines, starts with Sub Sample()
  • Variant 3 โ€” 26 lines, starts with Sub Main()
  • Variant 4 โ€” 15 lines, starts with Sub FillRandom()

Excel VBA objects referenced (5)

  • Application โ€” Using events with the Application object
  • Application โ€” Working with Other Applications
  • Range โ€” Refer to Cells by Using a Range Object
  • Range โ€” Delete Duplicate Entries in a Range
  • Rows.Count โ€” Count function (Microsoft Access SQL)

Top excel-vba Q&A (6)

+6 upvotes ranks this answer #114 out of 136 excel-vba solutions on this site .