Compare two tables

Hello,

I have a problem with comparing two tables. The problem is as follows: I have two sheets in Excel, 1 with the the administration up until august and one with the administration up until september. What I want to do is compare these two sheets (per row not per cell) and generate a new sheet with the differences between the two. I have a program from Ablebits data to compare two tables but this program has one problem when comparing the tables. The problem is that if a certain row occurs two times in sheet 1 and one time in sheet 2 it deletes all 3 of the rows instead of leaving one in sheet 1.

Please find attached a sheet as an example. In short I want to compare the two sheets and have 1 new sheets which shows me all the differences between the two (on a row level).

Thanks in advance for your help.

Marald

Please see the attachment. The code can be run from the View - macros button.

I've taken the approach of creating arrays for the two sheets which contain delimited concatenations of the rows. These are then compared and matches indicated by a flag within the array to deal with the multiple row problem. There is a sheet for additions and one for removals.

Code

Option Explicit

Sub GetChanges()
Dim OldArray()
Dim NewArray()
Dim N As Long
Dim M As Long
Dim FoundRow As Boolean
Dim RowValue

Sheets("Additions").Rows("2:" & Rows.Count).ClearContents
Sheets("Removals").Rows("2:" & Rows.Count).ClearContents


ReDim OldArray(Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row - 2, 1)
For N = 2 To Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
    For M = 1 To Sheets(1).Cells(1, Columns.Count).End(xlToLeft).Column
        OldArray(N - 2, 0) = OldArray(N - 2, 0) & Sheets(1).Cells(N, M) & Chr$(1)
    Next M
Next N

ReDim NewArray(Sheets(2).Cells(Rows.Count, 1).End(xlUp).Row - 2, 1)
For N = 2 To Sheets(2).Cells(Rows.Count, 1).End(xlUp).Row
    For M = 1 To Sheets(2).Cells(1, Columns.Count).End(xlToLeft).Column
        NewArray(N - 2, 0) = NewArray(N - 2, 0) & Sheets(2).Cells(N, M) & Chr$(1)
    Next M
Next N


'Additions
For N = 0 To UBound(NewArray, 1)
    FoundRow = False
    For M = 0 To UBound(OldArray, 1)
        If NewArray(N, 0) = OldArray(M, 0) And OldArray(M, 1) = "" Then
            FoundRow = True
            OldArray(M, 1) = 1
            Exit For
        End If
    Next M
    If FoundRow = False Then
        RowValue = Split(NewArray(N, 0), Chr$(1))
        Sheets("Additions").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) = RowValue(0)
        For M = 1 To UBound(RowValue)
            Sheets("Additions").Cells(Rows.Count, 1).End(xlUp).Offset(0, M) = RowValue(M)
        Next M
    End If
Next N


'Removals
For N = 0 To UBound(OldArray, 1)
    FoundRow = False
    For M = 0 To UBound(NewArray, 1)
        If OldArray(N, 0) = NewArray(M, 0) And NewArray(M, 1) = "" Then
            FoundRow = True
            NewArray(M, 1) = 1
            Exit For
        End If
    Next M
    If FoundRow = False Then
        RowValue = Split(OldArray(N, 0), Chr$(1))
        Sheets("Removals").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) = RowValue(0)
        For M = 1 To UBound(RowValue)
            Sheets("Removals").Cells(Rows.Count, 1).End(xlUp).Offset(0, M) = RowValue(M)
        Next M
    End If
Next N
End Sub

Thank you very much!! This was exactly what I was looking for!

Hello,

Just another question, when I use the macro provided before it gives me a few errors (please see attached file). Could someone help me with resolving these issues. For one Excel takes EUR 192,144 and turnes it into 192.144,00. I understand that it has something to do with the US/EUR way of using point and commas in numbers but switching my excel from EUR to US does not resolve the problem. Thansk in advance for your help.

Kind regards,

MaraldExample 2.xlsm

Can you try formatting the column in the additions sheet in EUR before running the code?

Thanks for your quick reply! I have tried convert the cells to Euros but this does not work. Any other tips?