Help-- Need a macro that will compare two spreadsheets and highlight changes

[tvjanes45]

Hello

I have two spreadsheets that I need to compare and identify any differences. I was using the below macro however, this macro didn't account for any new items was add each quarter. I need help writing a macro that will compare the spreadsheets, highlight and skip to the line if not found and continue search.

Sub RunCompare()

Call compareSheets("Before", "After")

End Sub


Sub compareSheets(shtBefore As String, shtAfter As String)

Dim mycell As Range
Dim mydiffs As Integer

For Each mycell In ActiveWorkbook.Worksheets(shtAfter).UsedRange
If Not mycell.Value = ActiveWorkbook.Worksheets(shtBefore).Cells(mycell.row, mycell.Column).Value Then

mycell.Interior.Color = vbYellow
mydiffs = mydiffs + 1

End If
Next

MsgBox mydiffs & " differences found", vbInformation

ActiveWorkbook.Sheets(shtAfter).Select

End Sub

 

[Gingertrees]

Does this run automatically, or do you have to choose to run it / press a button or something? If it's automatic, you might want to identify a column/row that changes with new quarterly additions, and move this into a Worksheet_Change module.

Otherwise, it might help to find a LastRow and LastColumn at the top of your macro:

With Sheet1
    LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    LastColumn = .Cells(.Cells(1, .Columns.Count).End(xlToLeft).Column
   '//////assuming LastRow and LastColumn can be measured by column A and row 1.
   '//////adjust as needed.
End With

and instead of your usedrange stuff, create a "WholeRng" range-variable that you set as = Range(Cells(1,1), Cells(LastRow, LastColumn)). [adjust as needed]
Then you can use this instead in your code. Maybe?

For each MyCell in WholeRng

 

[tvjanes45]

Thanks for the response but let me first say that I'm a newbie to code.

To answer your question, yes I have to push a button in order for the macro to run.

I feel like I need to have a macro that searches by the unique id (vlookup) then do the comparison.

 

[mumps]

From the code you posted, it looks like you are trying to compare every cell in one sheet to every cell in a particular row in the other sheet. I have a feeling that's not what you want to do. The easiest way to help us understand your request is to post a copy of your file. Perhaps you could upload a copy of your file to a free site such as www.box.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. Include a detailed explanation of what you would like to do referring to specific cells and worksheets.

 

[tvjanes45]

Thanks for the response

Here is my after (sheet 2) tab:
[TABLE="class: grid"]
<tbody>[TR]
[/TR]
[TR]
[/TR]
[TR]
[/TR]
[TR]
[TD][/TD]
[/TR]
</tbody>[/TABLE]
[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]

<tbody>
[TD="class: xl66"]Unique GL
[/TD]

</tbody>

[/TD]
[TD]USSGL Acct[/TD]
[TD]Title[/TD]
[TD]B/E[/TD]
[TD]F/N[/TD]
[TD]Reporting Type[/TD]
[TD]Addl. Info[/TD]
[/TR]
[TR]
[TD]1101000
[/TD]
[TD]101000[/TD]
[TD]Fund Balance With Treasury[/TD]
[TD]B[/TD]
[TD]N
[/TD]
[TD]E/U[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]1107000
[/TD]
[TD]107000[/TD]
[TD]New USSGL Added this Qtr[/TD]
[TD]E[/TD]
[TD]G[/TD]
[TD]E/U[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]1109000
[/TD]
[TD]109000[/TD]
[TD]Fund Balance With Treasury Under a Continuing Resolution[/TD]
[TD]E[/TD]
[TD]G[/TD]
[TD]E/U[/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

Here is my before (sheet1) tab:
[TABLE="class: grid"]
<tbody>[TR]
[TD]

<tbody>
[TD="class: xl66"]Unique GL.
[/TD]

</tbody>

[/TD]
[TD]USSGL Acct[/TD]
[TD]Title[/TD]
[TD]B/E[/TD]
[TD]F/N[/TD]
[TD]Reporting Type[/TD]
[TD]Addl. Info[/TD]
[/TR]
[TR]
[TD]1101000
[/TD]
[TD]101000[/TD]
[TD]Fund Balance With Treasury[/TD]
[TD]B[/TD]
[TD]G[/TD]
[TD]E/U[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]1109000
[/TD]
[TD]109000[/TD]
[TD]Fund Balance With Treasury Under a Continuing Resolution[/TD]
[TD]E[/TD]
[TD]G[/TD]
[TD]E/U[/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

[TABLE="class: grid, width: 500"]
<tbody>[TR]
[/TR]
[TR]
[/TR]
[TR]
[/TR]
[TR]
[TD][/TD]
[/TR]
</tbody>[/TABLE]
Here is what I'm trying to accomplish:
1. Create a macro using each unique GL (column1) and do a comparison between sheet 1 and sheet 2 to identify the differences for each unique GL. Highlight the differences. (For example GL 1101000 Column 5 changed to N)
2. Create a macro that will identify (highlight) any new or deleted unique GL accounts. For example in sheet 2 GL-1107000 is new. This whole row should be highlighted.

 

[mumps]

By "deleted unique GL accounts" do you mean that it was deleted from Sheet2 but still exists in Sheet1? Then you would want to highlight the account in Sheet1. Is this correct?

 

[tvjanes45]

By "deleted unique GL accounts" do you mean that it was deleted from Sheet2 but still exists in Sheet1? Then you would want to highlight the account in Sheet1. Is this correct?

Response: Correct

 

[mumps]

Try:

Sub CompareVals()
    Application.ScreenUpdating = False
    Dim GL As Range, RngList As Object, rng As Range
    Set RngList = CreateObject("Scripting.Dictionary")
    Dim foundGL As Range
    Dim LastRow2 As Long
    Dim LastRow As Long
    LastRow = Sheets("Sheet2").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    For Each GL In Sheets("Sheet2").Range("A2:A" & LastRow)
        Set foundGL = Sheets("Sheet1").Range("A:A").Find(GL, LookIn:=xlValues, lookat:=xlWhole)
        If Not foundGL Is Nothing Then
            For Each rng In Sheets("Sheet1").Range("A" & foundGL.Row & ":G" & foundGL.Row)
                If Not RngList.Exists(rng.Value) Then
                    RngList.Add rng.Value, Nothing
                End If
            Next rng
            For Each rng In Sheets("Sheet2").Range("A" & GL.Row & ":G" & GL.Row)
                If Not RngList.Exists(rng.Value) Then
                    rng.Interior.ColorIndex = 6
                End If
            Next rng
        Else
            GL.EntireRow.Interior.ColorIndex = 3
        End If
    Next GL
    LastRow2 = Sheets("Sheet1").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    For Each GL In Sheets("Sheet1").Range("A2:A" & LastRow)
        Set foundGL = Sheets("Sheet2").Range("A:A").Find(GL, LookIn:=xlValues, lookat:=xlWhole)
        If foundGL Is Nothing Then
            GL.EntireRow.Interior.ColorIndex = 3
        End If
    Next GL
End Sub

 

[tvjanes45]

Try:

Sub CompareVals()
    Application.ScreenUpdating = False
    Dim GL As Range, RngList As Object, rng As Range
    Set RngList = CreateObject("Scripting.Dictionary")
    Dim foundGL As Range
    Dim LastRow2 As Long
    Dim LastRow As Long
    LastRow = Sheets("Sheet2").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    For Each GL In Sheets("Sheet2").Range("A2:A" & LastRow)
        Set foundGL = Sheets("Sheet1").Range("A:A").Find(GL, LookIn:=xlValues, lookat:=xlWhole)
        If Not foundGL Is Nothing Then
            For Each rng In Sheets("Sheet1").Range("A" & foundGL.Row & ":G" & foundGL.Row)
                If Not RngList.Exists(rng.Value) Then
                    RngList.Add rng.Value, Nothing
                End If
            Next rng
            For Each rng In Sheets("Sheet2").Range("A" & GL.Row & ":G" & GL.Row)
                If Not RngList.Exists(rng.Value) Then
                    rng.Interior.ColorIndex = 6
                End If
            Next rng
        Else
            GL.EntireRow.Interior.ColorIndex = 3
        End If
    Next GL
    LastRow2 = Sheets("Sheet1").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    For Each GL In Sheets("Sheet1").Range("A2:A" & LastRow)
        Set foundGL = Sheets("Sheet2").Range("A:A").Find(GL, LookIn:=xlValues, lookat:=xlWhole)
        If foundGL Is Nothing Then
            GL.EntireRow.Interior.ColorIndex = 3
        End If
    Next GL
End Sub

Response: OMG THANK U THANK U THANK U. It worked perfectly. The only thing I'm going to change is the color of the deleted and added rows. The red is too bold lol

I appreciate all of your help with this. I pray this makes folks happy and they don't ask me for anything else.

 

[mumps]

You are very welcome.