Fastest Way To Compare 2 Excel Worksheets And Output Differences To 3rd Worksheet

[Jazattack]

I have a workbook that loads in the results of an SQL query into two worksheets called Old and New. The New worksheet is then edited by an end user. Rows can be inserted, deleted and values changed. There is a unique key in column M. With the following code, I am able to detect changes between Old and New, additions and deletions but it is slow and can take 10+ minutes to execute when looking at 5000+ rows. Would appreciate any advice in making this a faster process.

Sub Compare()
Dim OldArray as Variant
Dim NewArray as Variant

'Load List objects into arrays.
OldArray = Old.DataBodyRange
NewArray = New.DataBodyRange

For i = LBound(OldArray) to UBound(OldArray)
OldValueToFind = OldArray(i,IDColumn) 'Find the ID value in the i row.

With Sheets("New").Range("M:M") 'ID Column
Set NewRng = .Find(What:=OldValueToFind,  _
                        After:=.Cells(.Cells.Count), _
                        LookIn:=xlValues, _
                        LookAt:=xlWhole, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlNext, _
                        MatchCase:=True)
If Not NewRng Is Nothing Then 'Found OldValue in New Worksheet
NewRowIndex = NewRng.Row - 1 'Remove header column

  For j = LBound(OldArray, 2) to UBound(OldArray, 2) 'For each column in Old

        If j <> 2 and j <> 9 and j <> 10 and j <> 11 and j < 14 Then 'We don't care about comparing these value. There has to be a better way to discard these.
          If OldArray(i,j) <> NewArray(NewRowIndex, j) Then
          'Add new row to 3rd worksheet with differences
          End If
        End If
  Next
Else
  'Add new row to 3rd worksheet as this record has been deleted
End If
End With
Next
'End of checking for deletions and changes
'Now to repeat for NewArray to find any additional rows added.
For i = LBound(NewArray) to UBound(NewArray)
  NewRowValue = NewArray(i, IDColumn) 'Get ID Value from New Worksheet
  With Sheets("Old").Range("M:M")
    Set viewRng = .Find(What:=NewRowValue, _
                        After:=.Cells(.Cells.Count), _
                        LookIn:=xlValues, _
                        LookAt:=xlWhole, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlNext, _
                        MatchCase:=True)
    If viewRng Is Nothing Then 'Must be additional row as not found
    'Add new row to 3rd worksheet with all required columns.
    End If
  End With
Next
End Sub

 

[DanteAmor]

Welcome to the MrExcel Message Board!

Try the following. With 6000 records on each sheet, the result is immediate.
The results on the sheet "Sheet3".

Sub Compare_2_Sheets()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim dic1 As Object, dic2 As Object
  Dim a As Variant, b As Variant, c As Variant
  Dim i As Long, j As Long, k As Long, m As Long, n As Long
 
  Set sh1 = Sheets("New")
  Set sh2 = Sheets("Old")
  Set dic1 = CreateObject("Scripting.Dictionary")
  Set dic2 = CreateObject("Scripting.Dictionary")
 
  a = sh1.Range("A1", sh1.Cells(sh1.Range("M" & Rows.Count).End(3).Row, _
      sh1.Cells.Find("*", , xlValues, , xlByColumns, xlPrevious).Column)).Value
  b = sh2.Range("A1", sh2.Cells(sh2.Range("M" & Rows.Count).End(3).Row, _
      sh2.Cells.Find("*", , xlValues, , xlByColumns, xlPrevious).Column)).Value
 
  ReDim c(1 To UBound(a, 1) + UBound(b, 1), 1 To WorksheetFunction.Max(UBound(a, 2), UBound(a, 2)))
 
  For i = 1 To UBound(a, 1)
    dic1(a(i, 13)) = i        'fill dictionary news
  Next
  For i = 1 To UBound(b, 1)
    dic2(b(i, 13)) = i        'fill dictionary olds
  Next
 
  'find old value in news
  For i = 1 To UBound(b, 1)
    If dic1.exists(b(i, 13)) Then
      n = dic1(b(i, 13))
      For j = 1 To UBound(b, 2)     'For each column in Old
        If j <> 2 And j <> 9 And j <> 10 And j <> 11 And j < 14 Then
          If a(n, j) <> b(i, j) Then
            'Add row to 3rd worksheet with differences
            m = m + 1
            For k = 1 To UBound(a, 2)     'For each column in Old
              c(m, k) = a(n, k)           'Add the new data.
              'c(m, k) = b(i, k)           'if you want the old data
            Next k
            Exit For
          End If
        End If
      Next j
    Else
      'Add row to 3rd worksheet as this record has been deleted
      m = m + 1
      For k = 1 To UBound(b, 2)     'For each column in Old
        c(m, k) = b(i, k)
      Next k
    End If
  Next i
 
  'find new value in olds
  For i = 1 To UBound(a, 1)
    If Not dic2.exists(a(i, 13)) Then
      'Add row to 3rd worksheet because is new
      m = m + 1
      For k = 1 To UBound(b, 2)     'For each column in Old
        c(m, k) = a(i, k)
      Next k
    End If
  Next i
 
  Sheets("Sheet3").Range("A2").Resize(m, UBound(c, 2)).Value = c
End Sub

 

[Jazattack]

Welcome to the MrExcel Message Board!

Dante - Thank you very much for the response. I will give this a try this afternoon and provide feedback. It looks very promising though.

Thanks!

 

[Jazattack]

@DanteAmor - I've just tested this out and I can't believe how quickly it runs. I just need to make some modifications to record both previous and current values but this should be easy enough for me to manage.

Massive thanks again, very much appreciated!

 

[DanteAmor]

Im glad to help you, thanks for the feedback.