Consulting

Results 1 to 5 of 5

Thread: Compare Two Sheets and Extract Differences

  1. #1
    VBAX Regular
    Joined
    Jan 2016
    Posts
    41
    Location

    Compare Two Sheets and Extract Differences

    I already have a macro that will compare two worksheets and highlight differences. Now, I need a report that would be in a separate worksheet called “Report”.

    1. Wherever there is anything highlighted in the row, I want that whole row copied and pasted into “Report” sheet. “Status” column should be marked as “Change”.
    2. If there are any new rows in “New” sheet they should be copied and pasted in “Report” sheet. “Status” column should be marked as “Add”.
    3. In the case that there are some missing rows in “New” sheet, but they existed in the “Old”, I want those rows copied and pasted from “Old” into “Report”. “Status” column should be marked as “Missing”.


    Please see attached sample file. Let me know if you need more information. I appreciate help on this.
    Attached Files Attached Files

  2. #2
    VBAX Regular
    Joined
    Jan 2016
    Posts
    41
    Location
    I think I've found some solution to this. I modified Paul Hossler's macro:

    Sub HighlightChanges()
        Dim rDatabase As Range, rFile As Range
        Dim iFile As Long, iDatabase As Long, iColumn As Long
         
        Set rDatabase = Worksheets("Old").Cells(1, 1).CurrentRegion
        Set rFile = Worksheets("New").Cells(1, 1).CurrentRegion
         
        rFile.Interior.Color = xlNone
         
        For iFile = 2 To rFile.Rows.Count
             
            iDatabase = -1
             
            On Error Resume Next
            iDatabase = Application.WorksheetFunction.Match(rFile.Cells(iFile, 1).Value, rDatabase.Columns(1), 0)
            On Error GoTo 0
             
            If iDatabase <> -1 Then
                For iColumn = 2 To rFile.Columns.Count
                     '   changed to add CStr()'s
                    If CStr(rFile.Cells(iFile, iColumn).Value) <> CStr(rDatabase.Cells(iDatabase, iColumn).Value) Then
                        rFile.Cells(iFile, iColumn).Interior.Color = vbGreen
                    Else
                        rFile.Cells(iFile, iColumn).Interior.Color = vbYellow
                    End If
                Next iColumn
            End If
        Next iFile
         
    End Sub
    Cells that have difference, highlight in green, cells that have no difference highlight in yellow, those that are not highlighted are new products.

    If I switch worksheet names, I will get all missing lines from "New".

    Now, what's left is to transfer whole rows that have any cells highlighted in green and those without any highlights.

  3. #3
    Barim, I begun work on this and got the "Change" case where if it is highlighted, add it to the report sheet, see below code.

    After you implement this, let me know what you still need. I would have it all done, however some of your requests are a bit confusing.

    For example:
    -For the change case, are rows only ever going to be highlighted in the "New" sheet? Also, only rows D-F? Or A-F?
    -For the "Add" case, are you comparing the rows of OLD and NEW and if NEW has something that OLD doesnt, add it to report?

    Let me know if you need anything further.

    Sub RunReport()
    Dim WBT As Workbook
    Dim WPN As Worksheet
    Dim oldSheet As Worksheet
    Dim newSheet As Worksheet
    Dim ListOld(), ListNew()
    Dim change As String
    Dim add As String
    Dim missing As String
    change = "Change"
    add = "Add"
    missing = "Missing"
    
    
    ' Set workbook/worksheet variables
    Set WBT = ThisWorkbook
    Set WPN = WBT.Sheets(3)
    Set oldSheet = WBT.Sheets(1)
    Set newSheet = WBT.Sheets(2)
    
    
    firstRow = 2 ' Row after header
    lastRowOld = oldSheet.Cells(Rows.Count, "A").End(xlUp).Row
    lastRowNew = newSheet.Cells(Rows.Count, "A").End(xlUp).Row
    reportLastRow = WPN.Cells(Rows.Count, "A").End(xlUp).Row
    
    
    With oldSheet
        ListOld = Range(.Cells(firstRow, 2), .Cells(lastRowOld, 2)).Value
    End With
    With newSheet
        ListNew = Range(.Cells(firstRow, 2), .Cells(lastRowNew, 2)).Value
    End With
    
    
    ' New Case
    Dim ColorValues() As Variant
    ReDim ColorValues(LBound(ListNew) To UBound(ListNew))
    Dim table As Range
    For i = LBound(ColorValues) To UBound(ColorValues)
        Set table = newSheet.Range("C" & i)
        ColorValues(i) = table.Interior.Color
        If ColorValues(i) <> 16777215 Then
            newSheet.Rows(i).Copy WPN.Rows(reportLastRow + 1)
            newSheet.Cells(reportLastRow, 6).Value = change
            reportLastRow = reportLastRow + 1
        End If
        
        Set table = newSheet.Range("D" & i)
        ColorValues(i) = table.Interior.Color
        If ColorValues(i) <> 16777215 Then
            newSheet.Rows(i).Copy WPN.Rows(reportLastRow + 1)
            newSheet.Cells(reportLastRow, 6).Value = change
            reportLastRow = reportLastRow + 1
        End If
        
        Set table = newSheet.Range("E" & i)
        ColorValues(i) = table.Interior.Color
        If ColorValues(i) <> 16777215 Then
            newSheet.Rows(i).Copy WPN.Rows(reportLastRow + 1)
            newSheet.Cells(reportLastRow, 6).Value = change
            reportLastRow = reportLastRow + 1
        End If
    Next i
    
    
    End Sub

  4. #4
    VBAX Regular
    Joined
    Jan 2016
    Posts
    41
    Location
    Mattreingold, thank you so much for writing these codes.

    I tested your codes and it seems it is not "picking up".

    The first columns in both sheets are a lookup values and everything from B to E should be highlighted based on if anything changed. Column F in Report tab is just to print status of each line, based on which color.
    If there is any cell in the line highlighted as green it should be "Change"
    If the line is completely yellow it should be no action.
    If the line is not colored at all that should be "Add"

    Since, all changes are happening in "New" tab, with the above code I reverse sheet references just to find what is missing from new tab.

    I attached Example. As you can see in the Old tab one line is not highlighted which means it is missing in New. That line should be transferred to report tab and marked as "Missing". This should be the only type that should come from old tab. Sorry for this turned so complicated. What is more important to me is to transfer these lines into report tab, if statuses are so complicated to do maybe I can do something with conditional formatting.
    Again, thank you so much for your effort.
    Attached Files Attached Files

  5. #5
    Barim, I dont think the yellow/green highlighting is necessary. I can write you a piece of code that can recognize if something is not found in another location (I see in your example that Product 9 is missing from NEW, I can write code to recognize that).

    Instead, what would be helpful is if only the green highlighting is used, that makes the "Change" case easier, by recognizing if the cell is highlighted at all.

    I can continue helping monday, however this code should work below for the 'Change' case:

    I edited it slightly based on the example you provided, so it should run smoothly. (I don't know what you mean its not "picking up")

    NOTE: You need to remove the yellow highlighting for this to work, this runs based on which cells are highlighted. I will add segments about Add and Missing monday, but the only highlighting should be done is the green for the 'change' case.

    Sub RunReport()
    Dim WBT As Workbook
    Dim WPN As Worksheet
    Dim oldSheet As Worksheet
    Dim newSheet As Worksheet
    Dim ListOld(), ListNew()
    Dim change As String
    Dim add As String
    Dim missing As String
    change = "Change"
    add = "Add"
    missing = "Missing"
    
    
    
    
    ' Set workbook/worksheet variables
    Set WBT = ThisWorkbook
    Set WPN = WBT.Sheets(3)
    Set oldSheet = WBT.Sheets(1)
    Set newSheet = WBT.Sheets(2)
    
    
    
    
    firstRow = 2 ' Row after header
    lastRowOld = oldSheet.Cells(Rows.Count, "A").End(xlUp).Row
    lastRowNew = newSheet.Cells(Rows.Count, "A").End(xlUp).Row
    reportLastRow = WPN.Cells(Rows.Count, "A").End(xlUp).Row
    
    
    
    
    With oldSheet
        ListOld = Range(.Cells(firstRow, 2), .Cells(lastRowOld, 2)).Value
    End With
    With newSheet
        ListNew = Range(.Cells(firstRow, 2), .Cells(lastRowNew, 2)).Value
    End With
    
    
    
    
    ' New Case
    Dim ColorValues() As Variant
    ReDim ColorValues(LBound(ListNew) To UBound(ListNew))
    Dim table As Range
    For i = LBound(ColorValues) To UBound(ColorValues)
        Set table = newSheet.Range("C" & i)
        ColorValues(i) = table.Interior.Color
        If ColorValues(i) <> 16777215 Then
            newSheet.Rows(i).Copy WPN.Rows(reportLastRow + 1)
            WPN.Cells(reportLastRow + 1, 6).Value = change
            reportLastRow = reportLastRow + 1
        End If
        
        Set table = newSheet.Range("D" & i)
        ColorValues(i) = table.Interior.Color
        If ColorValues(i) <> 16777215 Then
            newSheet.Rows(i).Copy WPN.Rows(reportLastRow + 1)
            WPN.Cells(reportLastRow + 1, 6).Value = change
            reportLastRow = reportLastRow + 1
        End If
        
        Set table = newSheet.Range("E" & i)
        ColorValues(i) = table.Interior.Color
        If ColorValues(i) <> 16777215 Then
            newSheet.Rows(i).Copy WPN.Rows(reportLastRow + 1)
            WPN.Cells(reportLastRow + 1, 6).Value = change
            reportLastRow = reportLastRow + 1
        End If
    Next i
    
    
    
    
    End Sub

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •