Comparing two columns on Excel VBA

Question

I'm looking to compare two columns in excel using VBA. I'm using the below code, but its taking ages because there are thousands of cells. I'm looking to put a maximum limit but don't know how/where to apply that. I also don't know if anyone knows of a more efficient way of doing this code?

Private Sub CommandButton1_Click()
Dim Column1 As Range
Dim Column2 As Range

'Prompt user for the first column range to compare...
Set Column1 = Application.InputBox("Select First Column to Compare", Type:=8)

'Check that the range they have provided consists of only 1 column...
If Column1.Columns.Count > 1 Then
    Do Until Column1.Columns.Count = 1
        MsgBox "You can only select 1 column"
        Set Column1 = Application.InputBox("Select First Column to Compare", Type:=8)
    Loop
End If

'Prompt user for the second column range to compare...
Set Column2 = Application.InputBox("Select Second Column to Compare", Type:=8)

'Check that the range they have provided consists of only 1 column...
If Column2.Columns.Count > 1 Then
    Do Until Column2.Columns.Count = 1
        MsgBox "You can only select 1 column"
        Set Column2 = Application.InputBox("Select Second Column to Compare", Type:=8)
    Loop
End If

'Check both column ranges are the same size...
If Column2.Rows.Count <> Column1.Rows.Count Then
    Do Until Column2.Rows.Count = Column1.Rows.Count
        MsgBox "The second column must be the same size as the first"
        Set Column2 = Application.InputBox("Select Second Column to Compare", Type:=8)
    Loop
End If

'If entire columns have been selected, limit the range sizes
If Column1.Rows.Count = 11600 Then
    Set Column1 = Range(Column1.Cells(1), Column1.Cells(ActiveSheet.UsedRange.Rows.Count))
    Set Column2 = Range(Column2.Cells(1), Column2.Cells(ActiveSheet.UsedRange.Rows.Count))
End If

'Perform the comparison and set cells that are the same to yellow
Dim intCell As Long
For intCell = 1 To Column1.Rows.Count
    If Column1.Cells(intCell) = Column2.Cells(intCell) Then
        Column1.Cells(intCell).Interior.Color = vbYellow
        Column2.Cells(intCell).Interior.Color = vbYellow
    End If
Next
End Sub

Thanks.

Answer 1

I may suggest a couple of tweaks that could help.

1. Disable the screen update while the comparison loop is running. You can do this with:

    Application.ScreenUpdating = False  \n'Your loop here' \nApplication.ScreenUpdating = True  

2. Use variables for the expressions that repeat through the code, like

    Column1.Rows.Count  

I haven't test it, but it should be pretty fast to check it out ;)

Answer 2

Screen updating is a huge CPU suck, especially when you're changing the colors of cells. So @zfdn.cat's answer will definitely help you out.

Another thought, though: If many of your 10000s of rows are having their color changed, you'll also see a performance increase by keeping track of which cells need to change color, and setting the color of these cells once your loop is finished.

Something like...

Dim range_string as String
range_string = ""

Dim intCell As Long
For intCell = 1 To Column1.Rows.Count
    If Column1.Cells(intCell) = Column2.Cells(intCell) Then

        ' check if the range_string is empty
        ' if not, we'll add a comma to separate the next and previous points
        if range_string <> "" Then
            range_string = range_string & ","
        end if

        range_string = range_string & _
           Column1.Cells(intCell).Address & ":" &_
           Column1.Cells(intCell).Address & "," & _
           Column2.Cells(intCell).Address & ":" &_
           Column2.Cells(intCell).Address

    End If
Next

' Change the color of all the cells at once
Range(range_string).Interior.Color = vbYellow

I haven't tested the code, but the algorithm is solid... I think

Answer 3

You can try this (100'000 rows in 13,46 seconds):

 Sub Main()

    Dim Col1 As Range
    Dim Col2 As Range
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim i As Long

    Set wb = ThisWorkbook
    Set ws = wb.Sheets("Sheet1") ' Change the name of your Sheet


    Set Col1 = Application.InputBox("Select First Column to Compare", Type:=8)
    Set Col2 = Application.InputBox("Select First Column to Compare", Type:=8)

Application.ScreenUpdating = False

With ws
i = 1
Do While Not IsEmpty(.Cells(i, Col1.Column))

                If .Cells(i, Col1.Column) = .Cells(i, Col2.Column) Then
                    .Cells(i, Col1.Column).Interior.Color = vbYellow
                    .Cells(i, Col2.Column).Interior.Color = vbYellow
                End If
        i = i + 1
Loop

End With

Application.ScreenUpdating = True
End Sub