VBA executes slowly if there are blank cells

Question

I have the following macro in Excel VBA, and it works as I want. (Compares text in Column A of the Entry sheet, with Column A of the Clauses sheet, and highlights matching cells) But if there are any blank cells in column A of the Entry sheet, it runs very slow. It doesn't seem to matter if there are empty cells in the Clauses sheet. Any ideas how to make it so it doesn't take so long if someone leaves a cell blank?

Dim c As Range, fn As Range, adr As String
    With Sheets("sheet1")
        For Each c In .Range("A1", .Cells(Rows.Count, 1).End(xlUp))
            Set fn = Sheets("Clauses").Range("A:A").Find(c.Value, , xlValues, xlWhole)
                If Not fn Is Nothing Then
                    adr = fn.Address
                    c.Interior.Color = RGB(255, 100, 50)
                    Do
                        fn.Interior.Color = RGB(255, 100, 50)
                        Set fn = Sheets("Clauses").Range("A:A").FindNext(fn)
                    Loop While fn.Address <> adr
                End If
        Next
    End With

I have tried using If Not c Is Nothing Then and <>"". I'm just not sure if I am using them correctly?

Answer 1

Highlight Matches in the Source and Destination

• Never search for a value in a whole worksheet column.
• You could use .End(xlUp) for both columns (adjust the first cells).

Sub HighlightMatches()
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' The Find method or the End property will fail if the worksheet is filtered.
    
    Dim sws As Worksheet: Set sws = wb.Sheets("Sheet1")
    'If sws.FilterMode Then sws.ShowAllData
    Dim srg As Range:
    Set srg = sws.Range("A2", sws.Cells(sws.Rows.Count, "A").End(xlUp))
    
    Dim dws As Worksheet: Set dws = wb.Sheets("Clauses")
    'If dws.FilterMode Then dws.ShowAllData
    Dim drg As Range:
    Set drg = dws.Range("A2", dws.Cells(dws.Rows.Count, "A").End(xlUp))
    
    Dim surg As Range, sCell As Range, sValue
    Dim durg As Range, dCell As Range, dAddress As String
    
    For Each sCell In srg.Cells
        sValue = sCell.Value
        If Len(CStr(sValue)) > 0 Then ' is not blank
            Set dCell = drg.Find(sValue, , xlValues, xlWhole)
            If Not dCell Is Nothing Then
                dAddress = dCell.Address
                Set surg = RefCombinedRange(surg, sCell)
                Do
                    Set durg = RefCombinedRange(durg, dCell)
                    Set dCell = drg.FindNext(dCell)
                Loop While dCell.Address <> dAddress
            End If
        End If
    Next sCell

    ' Clear and highlight in (almost) one go!

    If Not surg Is Nothing Then
        ClearAndHighlight srg, surg, RGB(255, 100, 50)
    End If
    
    If Not durg Is Nothing Then
        ClearAndHighlight drg, durg, RGB(255, 100, 50)
    End If

End Sub

Combine Ranges

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      References a range combined from two ranges.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefCombinedRange( _
    ByVal urg As Range, _
    ByVal arg As Range) _
As Range
    If urg Is Nothing Then Set urg = arg Else Set urg = Union(urg, arg)
    Set RefCombinedRange = urg
End Function

Clear and Highlight

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Clears the fill color of a range, and applies
'               a given fill color to another range.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub ClearAndHighlight( _
        ByVal ClearRange As Range, _
        ByVal HighlightRange As Range, _
        ByVal HighlightColor As Long)
     ClearRange.Interior.ColorIndex = xlNone
     HighlightRange.Interior.Color = HighlightColor
End Sub

Answer 2

It is taking so long because all the empty cells in your clauses sheet (that is every cell below your last cell with data) are having their colour changed. There are two ways you can fix this. Change the line If Not fn Is Nothing Then to be If Not fn Is Nothing And Not IsEmpty(c.Value) Then.

The other way is to restrict the range that you are processing which is a much cleaner option. Currently you are using the entire column in the Clauses sheet and a million+ cells below your last row are empty. You can adjust your code as follows:

Dim c As Range, fn As Range, adr As String

'>>> Begin insert
Dim strLastRow As String   ' Last row for sheet 'Clauses'

    strLastRow = Sheets("Clauses").Cells(Rows.Count, 1).End(xlUp).Address  'Get the Clauses last row once only
'<<< End insert
    
    With Sheets("sheet1")
        For Each c In .Range("A1", .Cells(Rows.Count, 1).End(xlUp))
'            Set fn = Sheets("Clauses").Range("A:A").Find(c.Value, , xlValues, xlWhole)              '<<< Delete
            Set fn = Sheets("Clauses").Range("A1", strLastRow).Find(c.Value, , xlValues, xlWhole)   '<<< Insert
                If Not fn Is Nothing Then
                    adr = fn.Address
                    c.Interior.Color = RGB(255, 100, 50)
                    Do
                        fn.Interior.Color = RGB(255, 100, 50)
'                        Set fn = Sheets("Clauses").Range("A:A").FindNext(fn)             '<<< Delete
                        Set fn = Sheets("Clauses").Range("A1", strLastRow).FindNext(fn)   '<<< Insert
                    Loop While fn.Address <> adr
                End If
        Next
    End With

Answer 3

I've achieved the same result, using the following formula as an input for conditional formatting (for the "Clauses" sheet):

=IF(AND(NOT(ISBLANK(A2)),IFERROR(MATCH(A2,Sheet1!A:A,0),FALSE)),TRUE,FALSE)

It looks as follows:

As the whole thing is Excel-formula based, the colouring is done instantaneously.