Compare Sheets

[TiffanyG]

I prepare quarterly reports and need to pick up any new accounts but also need to report accounts that were lost. Each account has a unique account number and all info about the account is in one row. For instance:

Sheet - 1Q
Branch Act # Name Rate Code
1 321 John Doe 6

Sheet - 2Q
1 321 Joh Doe 5

I want a VB Code that will compare 1Q and 2Q pick up this row and show it is now rated a 5 instead of 6 in a new sheet named consolidation. BUT if any accounts are new 2Q I need to pick them up OR if any have dropped off and are not on the 2Q I need pick them up.

Is this possible? I use VB but can only do simple procedures.
Any help is greatly appreciated!

 

[TiffanyG]

Oops, maybe I shouted too soon. I was just testing the macro and deleted one in 1Q and it didn't show up as 'dropped' on the consolidated sheet. Isn't that what the code is suppose to do? Is there a certain range defined that all information has to be within?

 

[jindon]

OK
This is assuming you have header on the 1st row and will use it for the heading on the Consolidate sheet
Note: Number of columns of sheet1 and sheet2 MUST be the same.

Hope this works

Sub test()
Dim a, i As Long, ii As Integer, w(), dic As Object
Set dic = CreateObject("Scripting.Dictionary")
With Sheets("Sheet1") '<- alter to suite
    a = Range("a1").CurrentRegion.Value
End With
For i = 1 To UBound(a,1)
    If Not dic.exists(a(i,1)) Then
        ReDim w(1 To UBound(a,2) + 1)
        For ii = 1 To UBound(a,2) : w(ii) = a(i,ii) : Next
        dic.add a(i,1), w
    End If
Next
With Sheets("Sheet2")
    a = .Range("a1").CurrentRegion.Value
End With
For i = 1 To UBound(a,1)
    If Not dic.exists(a(i,1)) Then
        ReDim w(1 To UBound(a,2) + 1)
        For ii = 1 To UBound(a,2) : w(ii) = a(i,ii) : Next
        w(UBound(w)) = "New" : dic.add a(i,1) , w
    Else
        w = dic(a(i,1))
        If w(UBound(w)) <> "New" Then
            If w(3) <> a(i,3) Then
                w(3) = a(i,3) : w(UBound(w)) = "Changed"
            End If
        End If
        dic(a(i,1)) = w
    End If
Next
y = dic.items : Set dic = Nothing : Erase a
With Sheets("Consolidate").Range("a1")
    .CurrentRegion.ClearContents
    .EntireRow.Value = Sheets("Sheet1").Rows(1).Value ' Alter sheet name if needed
    .End(xlToRight).Offset(,1).Value = "Status"
    For i = 1 To UBound(y)
        .Offset(i).Resize(,UBound(y(i))).Value = y(i)
        If IsEmpty(y(i)(UBound(y(i)))) Then .Offset(i,4).Value = "Dropped"
    Next
End With
End Sub

 

[Fazza]

Tiffany & Jindon,

A query table approach via code. Especially suits if you have lots of data.

Sheet names must be "1Q" and "2Q"; data starts in cells A1; column headers "Account #", "Name", "Risk Grade" & "Balance".

Unformatted report is created to a new workbook.

HTH, Fazza

Sub Report()
    
    Dim sConn As String
    Dim sSQL As String
    
    Dim wks As Worksheet
    
    Worksheets("1Q").Range("A1").CurrentRegion.Name = "tbl_1Q"
    Worksheets("2Q").Range("A1").CurrentRegion.Name = "tbl_2Q"
    
    sConn = "ODBC;DSN=Excel Files;DBQ=" & _
            ActiveWorkbook.FullName & _
            ";DefaultDir=" & ActiveWorkbook.Path & _
            ";DriverID=790;MaxBufferSize=2048;PageTimeout=5;"
    
    sSQL = "SELECT 'Removed 2Q' AS [Account Change], tbl_1Q.`Account #`, tbl_1Q.Name, tbl_1Q.`Risk Grade`, tbl_1Q.Balance" & vbCr & _
            "FROM {oj tbl_1Q tbl_1Q LEFT OUTER JOIN tbl_2Q tbl_2Q ON tbl_1Q.`Account #` = tbl_2Q.`Account #`}" & vbCr & _
            "WHERE (tbl_2Q.`Account #` Is Null)" & vbCr & _
            "UNION ALL" & vbCr & _
            "SELECT 'Added 2Q' AS [Account Change], tbl_2Q.`Account #`, tbl_2Q.Name, tbl_2Q.`Risk Grade`, tbl_2Q.Balance" & vbCr & _
            "FROM {oj tbl_2Q tbl_2Q LEFT OUTER JOIN tbl_1Q tbl_1Q ON tbl_2Q.`Account #` = tbl_1Q.`Account #`}" & vbCr & _
            "WHERE (tbl_1Q.`Account #` Is Null)" & vbCr & _
            "UNION ALL" & vbCr & _
            "SELECT 'Risk Change 2Q' AS [Account Change], tbl_2Q.`Account #`, tbl_2Q.Name, tbl_2Q.`Risk Grade`, tbl_2Q.Balance" & vbCr & _
            "FROM tbl_1Q tbl_1Q, tbl_2Q tbl_2Q" & vbCr & _
            "WHERE tbl_2Q.`Account #` = tbl_1Q.`Account #` AND tbl_2Q.`Risk Grade` <> tbl_1Q.`Risk Grade`"
    
    
    Set wks = Worksheets.Add
    
    With wks
        .Name = "Report " & Format$(Now, "h.mm am/pm d mmm yy")
        With .QueryTables.Add(Connection:=sConn, Destination:=.Range("A1"), Sql:=sSQL)
            .Refresh BackgroundQuery:=False
        End With
        .Move
    End With
    Set wks = Nothing
    
End Sub

 

[Fazza]

post script

FYI: you can have the fields in any order and in any column so long as there is a contiguous block of data, and the headers names are correct.

 

[jindon]

Oops, maybe I shouted too soon. I was just testing the macro and deleted one in 1Q and it didn't show up as 'dropped' on the consolidated sheet. Isn't that what the code is suppose to do? Is there a certain range defined that all information has to be within?

You need to run the code each time you change the data in any of the sheet.

If you need it to be automated then we need to assing the code onto Sheet_Activate event

1) Right click on the sheet tab of Consolidate and select [ViewCode]
2) paste the code onto the right pane and close it to get back to excel
the code will run each time you select Consolidate sheet

Private Sub Worksheet_Activate()
    test
End Sub

 

[TiffanyG]

jindon,
i ran the code and it still indicated new for each account. am i doing something else wrong?

 

[jindon]

OK I will check my code.

Meanwhile, why don't you try Fazza's?

 

[TiffanyG]

Thanks, I will. If you get your to work I would like to check it out. As I said I am trying to learn VB.

 

[jindon]

Ah,,

With Sheets("Sheet1") '<- alter to suite
    a = Range("a1").CurrentRegion.Value
End With

Can you add "." period infront of Range("a1")

Should read as

a = .Range("a1").CurrentRegion.Value

and the code is assuming you don't have any blank row within the data area

 

[TiffanyG]

Now it picks up any new and any dropped but any that have remained the same indicate dropped.