Macro adjustment - compare two sheets

Robert Mika

MrExcel MVP
Joined
Jun 29, 2009
Messages
7,256
I have report downloading every day.
It has around 500 rows.
Every day I need to go through all of the lines to find small changes.

This macro is comparing two rows in sheets and will copy all differences to Sheet3.

Code:
Public Sub ReconReport()
    Dim rngCell As Range
    
    For Each rngCell In Worksheets("Sheet1").UsedRange
        If Not rngCell = Worksheets("Sheet2").Cells(rngCell.Row, rngCell.Column) Then _
            Let Worksheets("Sheet3").Cells(rngCell.Row, rngCell.Column) = rngCell
    Next
End Sub
The problem is that it is comparing rows not actually entries.
(Data in row of today's report (let say 2) can be in different row on yesterday’s (let say 5)
Is the a way to compare those entries and paste the difference to another sheet?
 

Some videos you may like

Excel Facts

Move date out one month or year
Use =EDATE(A2,1) for one month later. Use EDATE(A2,12) for one year later.

al_b_cnu

Well-known Member
Joined
Jul 18, 2003
Messages
4,494
Hi

Do you have a one or more columns which can act as a unique key?

If so, maybe you can use the dictionary object
 

Robert Mika

MrExcel MVP
Joined
Jun 29, 2009
Messages
7,256
Hi al_b_cnu,

Thanks for replay.
Yes there is a key.
Please see an example

Yesterday:


Today:


D3 has change from Hold to Ready and a new number has been added.

The key is the Id number and on new report will be always consecutive.

There is only an example and on real report there is more column and rows.
I'm not real good at macros so not sure how to use dictionary object.
 

al_b_cnu

Well-known Member
Joined
Jul 18, 2003
Messages
4,494

ADVERTISEMENT

Sorry for the dalay - the weekend got in the way :)

Try this macro:
Code:
Option Explicit
Dim miMaxColumns As Integer
Sub CompareSheets()
Dim bChanged As Boolean, baChanged() As Boolean
Dim iColEnd As Integer, iCol As Integer, iCol1 As Integer, iCol2 As Integer
Dim lRow1 As Long, lRow2 As Long, lReportRow As Long
Dim objDictOld As Object, objDictNew As Object
Dim vKeys As Variant, vKey As Variant
Dim vaInput() As Variant, vaOutput() As Variant, vaOutput2() As Variant
Dim vaInputOld As Variant, vaInputNew As Variant
Dim wsOld As Worksheet, wsNew As Worksheet, wsReport As Worksheet

Set wsOld = Sheets("Sheet1")
Set objDictOld = PopulateDictionary(WS:=wsOld)
Set wsNew = Sheets("Sheet2")
Set objDictNew = PopulateDictionary(WS:=wsNew)

Set wsReport = Sheets("Sheet3")

miMaxColumns = wsOld.Cells(1, Columns.Count).End(xlToLeft).Column

With wsReport
    .Cells.ClearFormats
    .Cells.ClearContents
End With

wsOld.Range("A1:" & wsOld.Cells(1, miMaxColumns).Address).Copy
wsReport.Range("B1").PasteSpecial xlPasteValues
Application.CutCopyMode = False

lReportRow = 1
vKeys = objDictOld.Keys
For Each vKey In vKeys
    ReDim vaInputOld(1 To 1, 1 To miMaxColumns)
    vaInputOld = objDictOld.Item(vKey)
    If objDictNew.exists(vKey) Then
        ReDim vaInputNew(1 To 1, 1 To miMaxColumns)
        vaInputNew = objDictNew.Item(vKey)
        ReDim vaOutput(1 To 1, 1 To miMaxColumns + 1)
        ReDim vaOutput2(1 To 1, 1 To miMaxColumns + 1)
        ReDim baChanged(1 To miMaxColumns)
        bChanged = False
        For iCol = 1 To miMaxColumns
            vaOutput(1, iCol + 1) = vaInputOld(1, iCol)
            If vaInputOld(1, iCol) <> vaInputNew(1, iCol) Then
                vaOutput2(1, iCol + 1) = vaInputNew(1, iCol)
                baChanged(iCol) = True
                bChanged = True
            End If
        Next iCol
        If bChanged Then
            lReportRow = lReportRow + 1
            For iCol = 1 To UBound(baChanged)
                If baChanged(iCol) Then
                    With wsReport
                        .Range(.Cells(lReportRow, iCol + 1).Address, _
                               .Cells(lReportRow + 1, iCol + 1).Address).Interior.Color = vbYellow
                    End With
                End If
            Next iCol
            
            vaOutput(1, 1) = "Changed"
            With wsReport
                .Range(.Cells(lReportRow, 1).Address, _
                       .Cells(lReportRow, miMaxColumns + 1).Address).Value = vaOutput
                lReportRow = lReportRow + 1
                .Range(.Cells(lReportRow, 1).Address, _
                       .Cells(lReportRow, miMaxColumns + 1).Address).Value = vaOutput2
            End With
        End If
        objDictOld.Remove vKey
        objDictNew.Remove vKey
    Else
        ReDim vaOutput(1 To 1, 1 To miMaxColumns + 1)
        vaOutput(1, 1) = "Deleted"
        For iCol = 1 To miMaxColumns
            vaOutput(1, iCol + 1) = vaInputOld(1, iCol)
        Next iCol
        
        lReportRow = lReportRow + 1
        With wsReport
            .Range(.Cells(lReportRow, 1).Address, .Cells(lReportRow, miMaxColumns + 1).Address).Value = vaOutput
        End With
    End If
Next vKey

If objDictNew.Count <> 0 Then
    vKeys = objDictNew.Keys
    For Each vKey In vKeys
        ReDim vaOutput2(1 To 1, 1 To miMaxColumns + 1)
        vaInputNew = objDictNew.Item(vKey)
        vaOutput2(1, 1) = "Inserted"
        For iCol = 1 To miMaxColumns
            vaOutput2(1, iCol + 1) = vaInputNew(1, iCol)
        Next iCol
        lReportRow = lReportRow + 1
        With wsReport
            .Range(.Cells(lReportRow, 1).Address, .Cells(lReportRow, miMaxColumns + 1).Address).Value = vaOutput2
        End With
    Next vKey
End If

objDictOld.RemoveAll
Set objDictOld = Nothing
objDictNew.RemoveAll
Set objDictNew = Nothing
End Sub
Private Function PopulateDictionary(ByRef WS As Worksheet) As Object
Dim lRowEnd As Long, lRow As Long
Dim rCur As Range
Dim sKey As String

Set PopulateDictionary = Nothing
Set PopulateDictionary = CreateObject("Scripting.Dictionary")
lRowEnd = WS.Cells(Rows.Count, "A").End(xlUp).Row
For lRow = 2 To lRowEnd
    sKey = Trim$(LCase$(CStr(WS.Cells(lRow, 1).Value)))
    On Error Resume Next
    PopulateDictionary.Add key:=sKey, Item:=WS.Range(WS.Cells(lRow, 1).Address, _
                                            WS.Cells(lRow, miMaxColumns).Address).Value
    On Error GoTo 0
Next lRow
End Function
Continued ...
 

al_b_cnu

Well-known Member
Joined
Jul 18, 2003
Messages
4,494
... Continued

Using this input:
Excel Workbook
ABCDE
1IDNameProjectStatusComments
2456RobertKomaReadyIs Good
3478LoraKilHoldIs no good
4123xyzabcdefghi
Sheet1
Excel 2003
Excel Workbook
ABCDE
1IDNameProjectStatusComments
2456RobertKomaReadyIs Good
3478LoraKilReadyIs no good
4499MiloKuolPreparingMaybe
Sheet2
Excel 2003

gives these results:
Excel Workbook
ABCDEF
1IDNameProjectStatusComments
2Changed478LoraKilHoldIs no good
3Ready
4Deleted123xyzabcdefghi
5Inserted499MiloKuolPreparingMaybe
Sheet3
Excel 2003
 

Robert Mika

MrExcel MVP
Joined
Jun 29, 2009
Messages
7,256

ADVERTISEMENT

Thank you al_b_cnu
Works great!
 

al_b_cnu

Well-known Member
Joined
Jul 18, 2003
Messages
4,494
Hi,

On further testing, it seems to not work if you're not on Sheet1 when calling the macro.

Try this amended version:
Code:
Option Explicit
Dim miMaxColumns As Integer
Sub CompareSheets()
Dim bChanged As Boolean, baChanged() As Boolean
Dim iColEnd As Integer, iCol As Integer, iCol1 As Integer, iCol2 As Integer
Dim lRow1 As Long, lRow2 As Long, lReportRow As Long
Dim objDictOld As Object, objDictNew As Object
Dim vKeys As Variant, vKey As Variant
Dim vaInput() As Variant, vaOutput() As Variant, vaOutput2() As Variant
Dim vaInputOld As Variant, vaInputNew As Variant
Dim wsOld As Worksheet, wsNew As Worksheet, wsReport As Worksheet


Set wsOld = Sheets("Sheet1")
miMaxColumns = wsOld.Cells(1, Columns.Count).End(xlToLeft).Column
Set objDictOld = PopulateDictionary(WS:=wsOld)
Set wsNew = Sheets("Sheet2")
Set objDictNew = PopulateDictionary(WS:=wsNew)

Set wsReport = Sheets("Sheet3")

With wsReport
    .Cells.ClearFormats
    .Cells.ClearContents
End With

wsOld.Range("A1:" & wsOld.Cells(1, miMaxColumns).Address).Copy
wsReport.Range("B1").PasteSpecial xlPasteValues
Application.CutCopyMode = False

lReportRow = 1
vKeys = objDictOld.Keys
For Each vKey In vKeys
    ReDim vaInputOld(1 To 1, 1 To miMaxColumns)
    vaInputOld = objDictOld.Item(vKey)
    If objDictNew.exists(vKey) Then
        ReDim vaInputNew(1 To 1, 1 To miMaxColumns)
        vaInputNew = objDictNew.Item(vKey)
        ReDim vaOutput(1 To 1, 1 To miMaxColumns + 1)
        ReDim vaOutput2(1 To 1, 1 To miMaxColumns + 1)
        ReDim baChanged(1 To miMaxColumns)
        bChanged = False
        For iCol = 1 To miMaxColumns
            vaOutput(1, iCol + 1) = vaInputOld(1, iCol)
            If vaInputOld(1, iCol) <> vaInputNew(1, iCol) Then
                vaOutput2(1, iCol + 1) = vaInputNew(1, iCol)
                baChanged(iCol) = True
                bChanged = True
            End If
        Next iCol
        If bChanged Then
            lReportRow = lReportRow + 1
            For iCol = 1 To UBound(baChanged)
                If baChanged(iCol) Then
                    With wsReport
                        .Range(.Cells(lReportRow, iCol + 1).Address, _
                               .Cells(lReportRow + 1, iCol + 1).Address).Interior.Color = vbYellow
                    End With
                End If
            Next iCol
            
            vaOutput(1, 1) = "Changed"
            With wsReport
                .Range(.Cells(lReportRow, 1).Address, _
                       .Cells(lReportRow, miMaxColumns + 1).Address).Value = vaOutput
                lReportRow = lReportRow + 1
                .Range(.Cells(lReportRow, 1).Address, _
                       .Cells(lReportRow, miMaxColumns + 1).Address).Value = vaOutput2
            End With
        End If
        objDictOld.Remove vKey
        objDictNew.Remove vKey
    Else
        ReDim vaOutput(1 To 1, 1 To miMaxColumns + 1)
        vaOutput(1, 1) = "Deleted"
        For iCol = 1 To miMaxColumns
            vaOutput(1, iCol + 1) = vaInputOld(1, iCol)
        Next iCol
        
        lReportRow = lReportRow + 1
        With wsReport
            .Range(.Cells(lReportRow, 1).Address, .Cells(lReportRow, miMaxColumns + 1).Address).Value = vaOutput
            '-- Set the row to light grey
            .Range(.Cells(lReportRow, 2).Address, .Cells(lReportRow, miMaxColumns + 1).Address).Interior.ColorIndex = 15
        End With
    End If
Next vKey

If objDictNew.Count <> 0 Then
    vKeys = objDictNew.Keys
    For Each vKey In vKeys
        ReDim vaOutput2(1 To 1, 1 To miMaxColumns + 1)
        vaInputNew = objDictNew.Item(vKey)
        vaOutput2(1, 1) = "Inserted"
        For iCol = 1 To miMaxColumns
            vaOutput2(1, iCol + 1) = vaInputNew(1, iCol)
        Next iCol
        lReportRow = lReportRow + 1
        With wsReport
            .Range(.Cells(lReportRow, 1).Address, .Cells(lReportRow, miMaxColumns + 1).Address).Value = vaOutput2
            '-- Set the row to light green
            .Range(.Cells(lReportRow, 2).Address, .Cells(lReportRow, miMaxColumns + 1).Address).Interior.ColorIndex = 4
        End With
    Next vKey
End If

objDictOld.RemoveAll
Set objDictOld = Nothing
objDictNew.RemoveAll
Set objDictNew = Nothing
End Sub
Private Function PopulateDictionary(ByRef WS As Worksheet) As Object
Dim lRowEnd As Long, lRow As Long
Dim rCur As Range
Dim sKey As String

Set PopulateDictionary = Nothing
Set PopulateDictionary = CreateObject("Scripting.Dictionary")
lRowEnd = WS.Cells(Rows.Count, "A").End(xlUp).Row
For lRow = 2 To lRowEnd
    sKey = Trim$(LCase$(CStr(WS.Range("A" & lRow).Value)))
    On Error Resume Next
    PopulateDictionary.Add key:=sKey, Item:=WS.Range(WS.Cells(lRow, 1).Address, _
                                            WS.Cells(lRow, miMaxColumns).Address).Value
    On Error GoTo 0
Next lRow
End Function
 

Robert Mika

MrExcel MVP
Joined
Jun 29, 2009
Messages
7,256
yeah,
there was some sparks - I had to run the macro twice but i did not want to bother you again.
Thanks for the amended version.
I own you...
 

Diekund

New Member
Joined
Feb 1, 2010
Messages
14
Hi Alan,

Thanks for your great work :) I was wondering if there was a way to use your macro here and just compare columns A:O instead of the entire sheet? I have it working so far but my "Sheet1" has comments in columns P, Q and R which are lacking on "Sheet2". Also, the "Changed" function is not 100% required but I can live with it if it is a hassle to remove

massive kudos for your work so far

Thanks
J
 

Subscribe on YouTube

Watch MrExcel Video

Forum statistics

Threads
1,106,329
Messages
5,510,643
Members
408,806
Latest member
Hunlight

This Week's Hot Topics

  • Turn fraction around
    Hello I need to turn a fraction around, for example I have 1/3 but I need to present as 3/1
  • TIme Clock record reformatting to ???
    Hello All, I'd like some help formatting this (Tbl-A)(Loaded via Power Query) [ATTACH type="full" width="511px" alt="PQdata.png"]22252[/ATTACH]...
  • TextBox Match
    hi, I am having a few issues with my code below, what I need it to do is when they enter a value in textbox8 (QTY) either 1,2 or 3 the 3 textboxes...
  • Using Large function based on Multiple Criteria
    Hello, I can't seem to get a Large formula to work based on two criteria's. I can easily get a oldest value based one value, but I'm struggling...
  • Can you check my code please
    Hi, Im going round in circles with a Compil Error End With Without With Here is the code [CODE=rich] Private Sub...
  • Combining 2 pivot tables into 1 chart
    Hello everyone, My question sounds simple but I do not know the answer. I have 2 pivot tables and 2 charts that go with this. However I want to...
Top