How to speed up code using Application.Match

[cscotty]

Hi All,

I have written an code that compares two worksheets based on a unique ID and performs actions based on the differences (e.g. highlight new rows in green). The code works great, but I notice that when I have a lot of rows it takes a real long time to run as it is looping through each individual cell. I read that the code can be improved using Application.Match, but I have not been able to be successful coding it. Would someone please point me in the right direction? Attached is a snippet of my code. Happy to post more of the code if needed, but I felt this was the relevant part:

Sub compareReport1()
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim oldrep1 As Range, newrep1 As Range, uido As String, uidn As String
Dim inoldrep1 As Variant, innewrep1 As Variant
Dim wsold As Worksheet
Dim wsnew As Worksheet
Dim lastrowo As Long
Dim lastrown As Long
Dim endDate As Long
Set wsold = Sheets(4)
Set wsnew = Sheets(3)
lastrowo = wsold.Range("A" & Rows.Count).End(xlUp).Row
lastrown = wsnew.Range("A" & Rows.Count).End(xlUp).Row
endDate = wsnew.Range("J" & Rows.Count).End(xlUp).Row

Set oldrep1 = wsold.Range("N1:N" & lastrowo) 'set for UID column in old report
Set newrep1 = wsnew.Range("N1:N" & lastrown) 'set for UID column in new report
Set enddatecol = wsnew.Range("J4:J" & endDate) 'set for End Date column if present

wsnew.Activate 'Bring New Report to front

'compare Old sheet (sheets (4)) to New sheet (Sheets(3)) and Highlight new rows in Green on New sheet
For i = 4 To lastrown 'row 4 to last column in new sheet
    For j = 4 To lastrown 'row 4 to last column in old sheet
        If Sheets(3).Cells(i, 14).Value = Sheets(4).Cells(j, 14).Value Then ' change (i, xx) to reflect column# of UID
            For k = 1 To 30 'considering 30 columns in both sheets
                If Sheets(4).Cells(j, k).Value = "" And Sheets(4).Cells(j, k).Value <> Sheets(3).Cells(i, k) Then
                    Sheets(3).Cells(i, k).Interior.Color = vbGreen
                End If
            Next k
        End If
    Next j
Next i

Thanks so much in advance for your help!

 

[DanteAmor]

Hi @cscotty
Starting from the fact that you have unique ids in column N

on a unique ID and performs actions

So I propose the following:

- Compare the old with the new​

- if the ID does not exist in the new sheet, then in the old sheet it is highlighted as yellow.​

- If any data is different, then it is highlighted as green on both sheets.​

- Compare the NEW with the old​

- if the ID does not exist in the OLD sheet, then in the NEW sheet it is highlighted as yellow.​

In the macro are the comments, if any line does not work for you, you simply delete it.
The macro is designed with arrays and a dictionary, it should be faster, in the end the cells are highlighted in one step.

Sub compareReport_v2()
  Dim wsold As Worksheet, wsnew As Worksheet
  Dim dic As Object
  Dim a As Variant, b As Variant
  Dim rng1 As Range, rng2 As Range, rng3 As Range, rng4 As Range
  Dim i As Long, j As Long
 
  Set wsnew = Sheets(3)           'NEW
  Set wsold = Sheets(4)           'OLD
  Set rng1 = wsold.Range("AG1")   'color yellow in old sheet
  Set rng2 = wsold.Range("AG1")   'color green in old sheet
  Set rng3 = wsnew.Range("AG1")   'color green in NEW sheet
  Set rng4 = wsnew.Range("AG1")   'color yellow in NEW sheet

  Set dic = CreateObject("Scripting.Dictionary")
 
  a = wsnew.Range("A1:AD" & Range("N" & Rows.Count).End(3).Row).Value2
  b = wsold.Range("A1:AD" & Range("N" & Rows.Count).End(3).Row).Value2

  For i = 1 To UBound(a, 1)  'ID of the new sheet
    dic(a(i, 14)) = i
  Next

  'Compare the old with the new
  For i = 1 To UBound(b, 1)
    If Not dic.exists(b(i, 14)) Then
      'if the ID does not exist in the new sheet, then in the old sheet it is highlighted as yellow.
      Set rng1 = Union(rng1, wsold.Range("N" & i))
    Else
      For j = 1 To 30
        If a(dic(b(i, 14)), j) <> b(i, j) Then
          'If any data is different, then it is highlighted as green on both sheets.
          Set rng2 = Union(rng2, wsold.Cells(i, j))
          Set rng3 = Union(rng3, wsnew.Cells(dic(b(i, 14)), j))
        End If
      Next
    End If
  Next

  '------------
  dic.RemoveAll
  For i = 1 To UBound(b, 1)  'ID of the OLD sheet
    dic(b(i, 14)) = i
  Next

  'Compare the NEW with the old
  For i = 1 To UBound(a, 1)
    If Not dic.exists(a(i, 14)) Then
      'if the ID does not exist in the OLD sheet, then in the NEW sheet it is highlighted as yellow.
      Set rng4 = Union(rng4, wsnew.Range("N" & i))
    End If
  Next

  'If you don't want any of the colors, just remove the line of code.
  If Not rng1 Is Nothing Then rng1.Interior.Color = vbYellow    'color yellow in old sheet
  If Not rng2 Is Nothing Then rng2.Interior.Color = vbGreen     'color green in old sheet
  If Not rng3 Is Nothing Then rng3.Interior.Color = vbGreen     'color green in NEW sheet
  If Not rng4 Is Nothing Then rng4.Interior.Color = vbYellow    'color yellow in NEW sheet

  wsold.Range("AG1").Interior.ColorIndex = xlNone
  wsnew.Range("AG1").Interior.ColorIndex = xlNone

End Sub

--------------
Let me know the result and I'll get back to you as soon as I can.
Sincerely
Dante Amor
--------------