Fast / efficient VBA code to compare two columns in excel for a large database (about 9000 rows)

Question

I am trying to write an efficient and faster VBA code for a mismatched corresponding values, that will:

Check each value of column C against A1:A9000
If found: Copy values of column B and C and paste them against the found cell value (in column B and Column C) and also delete the old mismatched entry.

Running a for loop ends up doing 9000*9000 calculation , making is super slow. I am a beginner and do not know a faster way to do it. I know that .Find is a lot faster than using for loop.

Below is the sample mismatched data:

Column A	Column B	Column C
XYZ1	Comments for XYZ1	XYZ1
XYZ3	Comments for XYZ2	XYZ2
XYZ5
XYZ6	Comments for XYZ4	XYZ4
XYZ8	Comments for XYZ5	XYZ5
XYZ9

Notice that Values in Column B and Column C will always match and correspond correctly to each other. The mismatch is between A AND B & C.

Here's the desired result:

Column A	Column B	Column C
XYZ1	Comments for XYZ1	XYZ1
XYZ3
XYZ5	Comments for XYZ5	XYZ5
XYZ6
XYZ8
XYZ9

Notice that Column A cannot be altered or changed.

Here's what I have so far but it takes just way too long to process the code:

Sub Realign()
For i = 2 To 9000
Set Found = Sheets("Sheet1").Range("A:A").Find(What:=Worksheets("Sheet1").Cells(i, 3).Value, _
                                                       LookIn:=xlValues, _
                                                       LookAt:=xlWhole, _
                                                       SearchOrder:=xlByRows, _
                                                       SearchDirection:=xlNext, _
                                                       MatchCase:=False)
        If Found Is Nothing Then
            Worksheets("Sheet1").Cells(i, 2).Value = ""
            Worksheets("Sheet1").Cells(i, 3).Value = ""
         
        Else
            Found.Offset(0, 1).Value = Worksheets("Sheet1").Cells(i, 2).Value
            Found.Offset(0, 2).Value = Worksheets("Sheet1").Cells(i, 3).Value
End If
Next
Call Delete1
End Sub

Sub Delete1()

For i = 2 To 9000

If Not Worksheets("Sheet1").Cells(i, 3).Value = Worksheets("Sheet1").Cells(i, 1).Value Then

    Worksheets("Sheet1").Cells(i, 2).Value = ""
    Worksheets("Sheet1").Cells(i, 3).Value = ""
 
End If
Next

End Sub

Doesn't this run the risk of overwriting values in B/C which might otherwise have matched to some other row in ColA? For example if the first ColC value is XYZ8 then you will overwrite the XYZ5 values in that row before you get a chance to relocate them. — Tim Williams, May 21 '21 at 17:21
@SolarMike: Yes the code does work, I tried on a smaller sample dataset. However, as I start increasing the rows, it takes too long to process all 9000*9000 calculations. Thanks, I will give CodeReview a try. — Helixeye, May 21 '21 at 17:26
@TimWilliams: I don't think so, because the values in Column A,B and C are sorted from lowest to highest. .Find searches data from top down, and I think it eliminates the risk of overwriting values — Helixeye, May 21 '21 at 17:29
This is almost identical to a question recently posted on a [Microsoft Answers Forum](https://answers.microsoft.com/en-us/msoffice/forum/all/fast-efficient-vba-code-to-compare-two-columns-in/2e7c842c-52f1-4f4a-87c9-bf086adbe648). Some good solutions there. — Ron Rosenfeld, May 21 '21 at 23:16

Tim Williams · Answer 1 · 2021-05-21T18:03:27.897

Match() is faster than find:

EDIT: re-worked to avoid chances of overwriting (assuming no duplicates are present)

Sub Realign2()
    Dim ws As Worksheet, m, v, r As Long, arr, arr2
    Set ws = ThisWorkbook.Worksheets("Sheet2")
    
    arr = ws.Range("A1:C9000").Value 'get data as array
    
    arr2 = arr                       'make a copy
    
    'clear columns 2 and 3 in arr
    For r = 2 To UBound(arr, 1)
        arr(r, 2) = ""
        arr(r, 3) = ""
    Next r
    
    For r = 2 To UBound(arr2, 1)
        v = arr2(r, 3)
        If Len(v) > 0 Then
            m = Application.Match(v, ws.Range("A:A"), 0)
            If Not IsError(m) Then
                arr(m, 2) = arr2(r, 2)
                arr(m, 3) = arr2(r, 3)
            End If
        End If
    Next r
    ws.Range("A1:C9000").Value = arr
    
End Sub

Ron Rosenfeld · Answer 2 · 2021-05-22T12:59:10.010

Here is a Power Query solution. PQ is available in Windows Excel 2010+ and Office 365

To use it:

Select some cell in your Data Table
Data => Get&Transform => from Table/Range
When the PQ Editor opens: Home => Advanced Editor
Make note of the Table Name in Line 2
Paste the M Code below in place of what you see
Change the Table name in line 2 back to what was generated originally.
Read the comments and explore the Applied Steps to understand the algorithm

The basic algorithm consists of

split into two tables == column 1 and combined columns 2:3
do a left outer join of the tables -- this will retain all from the one, and only the matching rows from the other.

M Code

let
    Source = Excel.CurrentWorkbook(){[Name="Table6"]}[Content],

//split into two tables
    //Add index column to TblA for sorting back to original tblA order
    tblA = Table.SelectColumns(Source,"Column1"),
    #"Added Index" = Table.AddIndexColumn(tblA, "Index", 0, 1, Int64.Type),
    tblB = Table.SelectColumns(Source,{"Column2","Column3"}),

//rejoin using joinkind.leftouter -- retains only rows that exist in left side table (tblA)
    joined = Table.Join(#"Added Index","Column1",tblB,"Column3",JoinKind.LeftOuter),
    #"Sorted Rows" = Table.Sort(joined,{{"Index", Order.Ascending}}),
    #"Removed Columns" = Table.RemoveColumns(#"Sorted Rows",{"Index"})
in 
    #"Removed Columns"

EDIT: Did a test on made-up data of about 9,000 rows and it ran in a fraction of a second.

Fast / efficient VBA code to compare two columns in excel for a large database (about 9000 rows)

2 Answers2