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!

 

[Jeffrey Mahoney]

I don't believe Match would work in this code. Match would still have to be run in a loop to find them all.

I think the problem is that you're setting the color of each cell one at a time. This saves all the cells into one range, then colors them at the end. Try it and see if it improves the speed.

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
  Dim u As Range
  
  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
                      If Not u Is Nothing Then
                        Set u = Union(Sheets(3).Cells(i, k), u)
                      Else
                        Set u = Sheets(3).Cells(i, k)
                      End If
                  End If
              Next k
          End If
      Next j
  Next i
  If Not u Is Nothing Then
    u.Interior.Color = vbGreen
  End If

End Sub

 

[cscotty]

'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 If Not u Is Nothing Then Set u = Union(Sheets(3).Cells(i, k), u) Else Set u = Sheets(3).Cells(i, k) End If End If Next k End If Next j Next i If Not u Is Nothing Then u.Interior.Color = vbGreen End If

Hi Jeffrey,

Thanks so much for the help. The code works, but it still takes a long time to run. Do you think creating an array of both sheets then comparing and coloring them that way would work faster?

Thanks!

 

[Jeffrey Mahoney]

I don't know how many rows you're evaluating, but for each 100 rows it is having to compare 3,100 cells. You might save some time loading the values of the cells into an array. The overhead in the code may be a little too much to manage.

Have you considered Conditional Formatting? You could use ROW() and Column() references to compare the cells from both sheets

 

[Jeffrey Mahoney]

Wait a minute. I'm thinking your code is comparing Sheet 4 data over and over again

 

[Jeffrey Mahoney]

Are you not trying to compare each cell from sheet 3 to each cell of sheet 4?

In the code you are comparing sheet 3 line 4 to sheet 4 line 4, 5, 6, 7...
Then in the next iteration:
Comparing Sheet 3 line 5 to Sheet 4 line 4,5,6,7,...

I may be wrong, but it looks like a whole lotta duplicate checking

 

[cscotty]

Are you not trying to compare each cell from sheet 3 to each cell of sheet 4?

In the code you are comparing sheet 3 line 4 to sheet 4 line 4, 5, 6, 7...
Then in the next iteration:
Comparing Sheet 3 line 5 to Sheet 4 line 4,5,6,7,...

I may be wrong, but it looks like a whole lotta duplicate checking

Wow, thanks for the insight Jeffrey!

What I'm essentially trying to do is compare two worksheets to identify the difference (e.g. new rows, removed rows, changed values). It first finds the unique ID in the new sheet (Sheets(3)) and then finds it in the same column reference in the old sheet (Sheets(4)). Once it finds it, it checks each cell within that row for changes. If a change is present it addresses it appropriately. In this example, if the unique ID does not exist in the old sheet, then it highlights the entire row in the new sheet green.

Hope this helps!

 

[Jeffrey Mahoney]

Ok, so you are trying to save a snapshot of your table on Sheet4, then at some time later check all the differences? If that is the case, you should make your markups on Sheet4. Otherwise, how would know a row is missing unless you use sheet4 as the baseline and how would you mark a missing row on sheet3?

Let's lay this out logically. The macro checks the first record on sheet4. It tries to find that same record on sheet3 by the data in column 14.
* It finds the record on the same row and the data matches the other 30 columns: Do nothing
* It finds the record on a different row: mark the current record on sheet4 as grey background
* It finds the record and the data doesn't match the other 30 columns: Mark current row on sheet4 as font = red
* It doesn't find the record: Mark current record on sheet4 as strikeout font

Now I'm changing my tone on getting Sheet3 Data into an array. IF column 14 is your unique ID, then yes, we can use match. Tell me what you think about my thoughts. I'll help all I can.

Jeff

 

[Jeffrey Mahoney]

I don't have any of your data so I can't test this. It's based on what I was talking about on my last post

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
  Dim u As Range
  Dim Cel As Range
  Dim ID As String
  Dim M As Long
  Dim OldRowRng As Range
  Dim NewRowRng As Range
  Dim AStr As String
  Dim BStr As String
  Dim WSOldRng As Range
  Dim WSNewRng As Range
  Dim OldRow As Long
  Dim NewRow 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
  Set WSOldRng = WSOld.Range(WSOld.Cells(1, 1), WSOld.Cells(LastRowO, 30))
  Set WSNewRng = WSNew.Range(WSNew.Cells(1, 1), WSNew.Cells(LastRowN, 30))
  
  For Each Cel In OldRep1
    ID = Cel.Value
    OldRowRng = Intersect(WSOldRng, Cel.EntireRow)
    OldRow = Cel.Row
    AStr = Application.TextJoin(",", False, OldRowRng)
    M = 0
    On Error Resume Next
    M = Application.Match(ID, NewRep1, 0)
    On Error GoTo 0
    NewRow = M
    If M > 0 Then
      Set NewRowRng = Intersect(WSNewRng, WSNew.Cells(M, 1).EntireRow)
      BStr = Application.TextJoin(",", False, NewRowRng)
    End If
    
    If M = 0 Then
      OldRowRng.Font.Strikethrough = True
    ElseIf NewRow <> OldRow Then                                              'Found on different row
      With OldRowRng.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = -0.249977111117893
        .PatternTintAndShade = 0
      End With
    End If
    If M > 0 And BStr <> AStr Then                                                  'Record data doesn't match
      With OldRowRng.Font
        .Color = -16776961
        .TintAndShade = 0
      End With
    End If
  Next Cel
    
End Sub

 

[Jeffrey Mahoney]

Your profile doesn't show what version of Excel you're using. I hope I didn't functions you don't have.