Comparing two sheets

[keiranwyllie]

Hello gurus, I've been trying to nut this one out but it's got me stumped.

Scenario: I have two worksheets. The 2nd (System Security Plan Annex Template (March 2023)) is considered a new version of the first (System Security Plan Annex Template (December 2022)) therefore it will mostly have the same data on each row however there may be more, or may be less rows depending on what the revision commits.

The code I've tried working on, which is run from the original sheet, endeavours to do the following:
1. Create 'newSheet' and copy data from Sheet1 (up to column N down to lastrow), on to newSheet and converts it to a table - This works
2. Opens the updated workbook and imports sheet1 (up to column N down to lastrow(which is most likely different to original workbook)) to newSheet, pasting at cell P1, then converts to table - this also works
3. Retains any comments as the comparison completes that may have existed in columns O,P and Q (these will align with the value from column D)
4. Compares the two tables with the intent of meeting the following criteria:
a. Firstly compares each row entry in column D of the two tables
b. Then compares by revision date (if revision date of same items from 3a is a later revision in the 2nd workbook, it should keep that row)
c. Spits out a new list on a new sheet that retains anything from the original worksheet that was NOT different and also adds anything new (meaning new revision dates as well). It should also remove anything, based on column D, that is not in the updated worksheet as it's expected that it has been removed as part of the update.
The pièce de résistance would be that the final product then replace the original data on sheet1 of the original workbook - essentially completing the import of an updated dataset.

Workbook original - Original Data
Updated workbook - New Version

Any guidance on how to modify the code below would be great.

Sub CompareAndCreateNewTable()

Dim ws, srcBook, srcSheet As Worksheet
Dim lastRow, lastCol, rng, lastRowTable1, lastRowTable2 As Range

Set ws = Sheets(1)
Set NewSheet = ThisWorkbook.Worksheets.Add

ActiveSheet.Name = "newSheet"

lastRowTable1 = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
lastCol = ws.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column

Set rng = ws.Range("A1").Resize(lastRowTable1, lastCol - 3) 'Exclude the last 4 columns

rng.Copy NewSheet.Range("A1")

'ActiveSheet.ListObjects.Add(xlSrcRange, ActiveSheet.UsedRange, , xlYes).Name = "Table1"
ActiveSheet.ListObjects.Add(xlSrcRange, Range("A1", Range("A1").End(xlToRight).End(xlDown)), , xlYes).Name = "Table1"
ActiveSheet.ListObjects("Table1").TableStyle = "TableStyleLight2"

'Prompt the user to select a file
Dim fileName As String
fileName = Application.GetOpenFilename("Excel files (*.xlsx), *.xlsx")

'Open the file and get a reference to the source sheet
Set srcBook = Workbooks.Open(fileName)
Set srcSheet = srcBook.Worksheets(1)

lastRow = srcSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
lastCol = srcSheet.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column

Set rng = srcSheet.Range("A1").Resize(lastRow, lastCol - 3)
rng.Copy NewSheet.Range("P1")

srcBook.Close False

ActiveSheet.ListObjects.Add(xlSrcRange, Range("P1", Range("P1").End(xlToRight).End(xlDown)), , xlYes).Name = "Table2"
ActiveSheet.ListObjects("Table2").TableStyle = "TableStyleLight2"

    ' Get the last row of Table1
    'lastRowTable1 = Range("Table1").Rows.Count
    
    ' Get the last row of Table2
    'lastRowTable2 = Range("Table2").Rows.Count
    
    ' Initialize the new data array
    ReDim newData(1 To lastRowTable1, 1 To 5)
    
    ' Compare the tables based on column 4
    newRow = 1 ' Initialize the row counter for the new table
    
    For i = 1 To lastRowTable1
        Set cellTable1 = Range("Table1").Cells(i, 14)
        foundMatch = False ' Reset the flag for each row in Table1
        
        For j = 1 To lastRow
            Set cellTable2 = Range("Table2").Cells(j, 14)
            
            ' If the values in column 4 are equal, compare the other columns
            If cellTable1.Value = cellTable2.Value Then
                foundMatch = True
                
                ' Compare the other columns
                If cellTable1.Offset(0, -2).Value <> cellTable2.Offset(0, -2).Value _
                    Or cellTable1.Offset(0, -1).Value <> cellTable2.Offset(0, -1).Value _
                    Or cellTable1.Offset(0, 0).Value <> cellTable2.Offset(0, 0).Value _
                    Or cellTable1.Offset(0, 1).Value <> cellTable2.Offset(0, 1).Value _
                    Or cellTable1.Offset(0, 2).Value <> cellTable2.Offset(0, 2).Value _
                    Or cellTable1.Offset(0, 3).Value <> cellTable2.Offset(0, 3).Value _
                    Or cellTable1.Offset(0, 4).Value <> cellTable2.Offset(0, 4).Value _
                    Or cellTable1.Offset(0, 5).Value <> cellTable2.Offset(0, 5).Value _
                    Or cellTable1.Offset(0, 6).Value <> cellTable2.Offset(0, 6).Value _
                    Or cellTable1.Offset(0, 7).Value <> cellTable2.Offset(0, 7).Value _
                    Or cellTable1.Offset(0, 8).Value <> cellTable2.Offset(0, 8).Value _
                    Or cellTable1.Offset(0, 9).Value <> cellTable2.Offset(0, 9).Value _
                    Or cellTable1.Offset(0, 10).Value <> cellTable2.Offset(0, 10).Value _
                    Or cellTable1.Offset(0, 11).Value <> cellTable2.Offset(0, 11).Value _
                    Or cellTable1.Offset(0, 12).Value <> cellTable2.Offset(0, 12).Value _
                    Or cellTable1.Offset(0, 13).Value <> cellTable2.Offset(0, 13).Value Then
                    
                    ' Skip this row if there are differences
                    Exit For
                End If
                
                ' If there are no differences, add the row to the new table
                newData(newRow, 1) = cellTable1.Offset(0, -3).Value     ' Column A
                newData(newRow, 2) = cellTable1.Offset(0, -2).Value     ' Column B
                newData(newRow, 3) = cellTable1.Offset(0, -1).Value     ' Column C
                newData(newRow, 4) = cellTable1.Value                   ' Column D
                newData(newRow, 5) = cellTable1.Offset(0, 1).Value      ' Column E
                newData(newRow, 6) = cellTable1.Offset(0, 2).Value      ' Column F
                newData(newRow, 7) = cellTable1.Offset(0, 3).Value      ' Column G
                newData(newRow, 8) = cellTable1.Offset(0, 4).Value      ' Column H
                newData(newRow, 9) = cellTable1.Offset(0, 5).Value      ' Column I
                newData(newRow, 10) = cellTable1.Offset(0, 6).Value     ' Column J
                newData(newRow, 11) = cellTable1.Offset(0, 7).Value     ' Column K
                newData(newRow, 12) = cellTable1.Offset(0, 8).Value     ' Column L
                newData(newRow, 13) = cellTable1.Offset(0, 9).Value     ' Column M
                newData(newRow, 14) = cellTable1.Offset(0, 10).Value    ' Column N
                
                newRow = newRow + 1 ' Increment the row counter for the new table
                
                Exit For ' Move on to the next row in Table1
            End If
        Next j
        
        ' If no match was found for this row in Table1, skip the row
        If Not foundMatch Then
            ' Skip this row
        End If
    Next i
    
    ' Write the new table to a new sheet
    Set NewSheet = ThisWorkbook.Sheets.Add ' Create a new sheet
    
    ' Write the headers
    NewSheet.Range("A1:N1").Value = Array("Guideline", "Section", "Topic", "Identifier", "Revision", "Updated", "All", "O", "P", "S", "TS", "ML2", "ML3", "Description")
    
    ' Write the data
    NewSheet.Range("A2").Resize(UBound(newData, 1), UBound(newData, 2)).Value = newData
    
    ' Convert the dates in Column F to Date format
    NewSheet.Range("E:E").NumberFormat = "MMM-YY"
    
    ' Autofit the columns
    NewSheet.Columns.AutoFit
    
    ' Notify the user
    MsgBox "Comparison completed. Please check the new sheet for the results."
    
End Sub

 

[Killragtshirts]

Hi, Do you still need help with this? I took a quick look.

Firstly compares each row entry in column D of the two tables.

I noticed that in Column D there were obviously new entries as in new identifier numbers (For example ISM-1849). Are you wanting them to come into the new sheet as well or just numbers that match?

 

[keiranwyllie]

Hi, Do you still need help with this? I took a quick look.

Firstly compares each row entry in column D of the two tables.

I noticed that in Column D there were obviously new entries as in new identifier numbers (For example ISM-1849). Are you wanting them to come into the new sheet as well or just numbers that match?

I ended up finally working it out and even going so much further to add additional functionality such as turning the data on the new sheet into tables as more updates are introduced etc.

I'm sure this can be tidied up a heck of a lot but it does the job.

Sub ImportData()
Dim wb, wb2 As Workbook
Dim wsOld As Worksheet
Dim wsNew, backup, sht As Worksheet
Dim i As Long, j As Long, k As Long
Dim rowOld As Long, rowNew, lastRow, lastColumn, lastRowTbl As Long
Dim found, hasExistingTable As Boolean
Dim lastRowOrig As Long, lastRowUpd As Long, origRow As Long, updRow, nextBlankRow, rowRange1 As Long
Dim wsOriginal As Worksheet, wsUpdated As Worksheet
Dim filePath, sheetName As String
Dim sheetToImport As String
Dim copyRange, newRow, sortRange, sortKey1, sortKey2, sortKey3 As Range
Dim existingTable As ListObject
Dim newCol As ListColumn

sheetName = "Change Tracking"

On Error Resume Next
Set ws = ThisWorkbook.Sheets(sheetName)
On Error GoTo 0

If Not WorksheetExists(sheetName) Then
    Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    ws.Name = sheetName
    Else
    ' Do nothing
End If

If IsEmpty(Sheets(sheetName).Range("A1")) Then
    nextBlankRow = Sheets(sheetName).Cells(Sheets(sheetName).Rows.Count, "A").End(xlUp).Row
    ThisWorkbook.Worksheets(1).Rows(1).Copy Destination:=Sheets(sheetName).Rows(nextBlankRow)
Else
    nextBlankRow = Sheets(sheetName).Cells(Sheets(sheetName).Rows.Count, "A").End(xlUp).Row + 2
    ThisWorkbook.Worksheets(1).Rows(1).Copy Destination:=Sheets(sheetName).Rows(nextBlankRow)
End If

' Prompt user to select a file
filePath = Application.GetOpenFilename()

If filePath = "False" Then
    'User cancelled file selection
    Exit Sub
End If

' Open selected workbook
Set wb2 = Workbooks.Open(filePath)

' Import sheet into current workbook
wb2.Sheets(1).Copy After:=ThisWorkbook.Sheets(1)
ActiveSheet.Name = "Import"

' Close imported workbook
wb2.Close SaveChanges:=False

Set wb = ThisWorkbook                                                                                       'change to the appropriate workbook
Set wsOld = wb.Sheets(1)                                                                                    'change to the name of your existing sheet
Set wsNew = wb.Sheets("Import")                                                                                    'change to the name of the sheet with the new data

'Get last row in each sheet
lastRowOrig = wsOld.Cells(wsOld.Rows.Count, "D").End(xlUp).Row
lastRowUpd = wsNew.Cells(wsNew.Rows.Count, "D").End(xlUp).Row

'Loop through the original sheet
For origRow = lastRowOrig To 2 Step -1                              'start from the bottom to avoid issues with deleting rows
'Loop through the updated sheet to find matching value in column D
    For updRow = 2 To lastRowUpd
        If wsOld.Cells(origRow, "D").Value = wsNew.Cells(updRow, "D").Value Then
            Exit For                                                            'matched - exit loop
        End If
    Next updRow

    If updRow > lastRowUpd Then                                         'no match found in updated sheet - delete row in original sheet

        Set copyRange = wsOld.Rows(origRow)

        ' Copy the row to a new sheet (change Sheet2 as necessary)
        Set newRow = Sheets(sheetName).Rows(Sheets(sheetName).Cells.Rows.Count).End(xlUp).Offset(1, 0)
        copyRange.EntireRow.Copy newRow

        lastColumn = copyRange.End(xlToRight).Column
        newRow.Resize(1, lastColumn).Interior.Color = RGB(221, 217, 196)

        wsOld.Rows(origRow).Delete                                         ' Temporary disabled to ensure no deletion from original worksheet
    End If
Next origRow

'loop through rows of the new data
For i = 2 To wsNew.Cells(wsNew.Rows.Count, "D").End(xlUp).Row       'assuming data starts on row 2
    found = False
        'loop through rows of the old data
        For j = 2 To wsOld.Cells(wsOld.Rows.Count, "D").End(xlUp).Row       'assuming data starts on row 2
            'compare values in column D of old and new data
            If wsOld.Cells(j, "D").Value = wsNew.Cells(i, "D").Value Then
                found = True
                'update rows with more recent dates in column F
                If wsNew.Cells(i, "F").Value > wsOld.Cells(j, "F").Value Then
                    For k = 1 To 19                                                     'assuming comments are in columns O to S
                        wsOld.Cells(j, k + 14).Value = wsNew.Cells(i, k + 14).Value
                    Next k
                End If
                Exit For                                                            'exit loop once a match is found
            End If
        Next j
        'if no match is found, add the new row to the old data
        If Not found Then
            rowOld = wsOld.Cells(wsOld.Rows.Count, "D").End(xlUp).Row + 1
            rowNew = i
                'copy values from new data to old data
                For k = 1 To 18                                                     'assuming comments are in columns O to S
                    wsOld.Cells(rowOld, k).Value = wsNew.Cells(rowNew, k).Value
                    wsOld.Cells(rowOld, k + 14).Value = wsNew.Cells(rowNew, k + 14).Value
                Next k
                wsNew.Rows(rowNew).Copy Sheets(sheetName).Rows(Sheets(sheetName).Cells(Rows.Count, "A").End(xlUp).Row + 1)                  ' This should copy new data to the change tracking sheet
        End If
Next i

wsOld.Activate
lastRow = wsOld.Cells(Rows.Count, "D").End(xlUp).Row                'get the last row number in column D
Range("F2:F" & lastRow).NumberFormat = "dd-mmm"

For i = lastRow To 2 Step -1                                        'loop through rows starting from the last one
    For j = i - 1 To 1 Step -1                                      'loop through rows before the current row

    If Range("D" & i).Value = Range("D" & j).Value Then             'if the values in column D match
        If Range("F" & i).Value <= Range("F" & j).Value Then        'if the date in column F of the current row is less than or equal to the date in column F of the matching row
            Rows(i).Delete                                          'delete the current row
            Exit For                                                'exit the inner loop - TEMP DISABLED
        Else
            Rows(j).Delete                                          'delete the matching row - TEMP DISABLED
            Exit For                                                'exit the inner loop
        End If
    End If

    Next j
Next i

For Each existingTable In Sheets(sheetName).ListObjects
    If Left(existingTable.Name, 9) = "tblUpdate" Then
        hasExistingTable = True
        Exit For
    End If
Next existingTable

' Convert the new data on "sheetName" to a table if there are no existing tables
If Not hasExistingTable Then
    Dim tbl As ListObject
    Set tbl = Sheets(sheetName).ListObjects.Add(xlSrcRange, Sheets(sheetName).UsedRange, , xlYes)
    tbl.Name = "tblUpdate001"
    
    ' Apply table formatting
    With tbl
        .TableStyle = "TableStyleLight2" ' Modify the table style as desired
        .ShowTableStyleFirstColumn = False
        .ShowTableStyleLastColumn = False
    End With
    
    Set newCol = tbl.ListColumns.Add(Position:=21)
    newCol.Name = "CoA Review of Change"
    
    ' Auto-fit the column widths in the table
    tbl.Range.Columns.AutoFit
    
    'group columns F to M
    Set colRange1 = tbl.Range.Columns("F:M")
    colRange1.Group
    colRange1.EntireColumn.Hidden = True 'expand the group

    'group columns O to T
    Set colRange2 = tbl.Range.Columns("O:T")
    colRange2.Group
    colRange2.EntireColumn.Hidden = True 'expand the group
    
    lastRowTbl = tbl.Range.Rows.Count
    If lastRowTbl > 1 Then
        tbl.Range.Rows("2:" & lastRowTbl).Group
    End If
    
    tbl.ListColumns(21).Range.ColumnWidth = 60
    tbl.ListColumns(21).Range.Font.Size = 10
    tbl.ListColumns(21).Range.WrapText = True
    tbl.ListColumns(21).Range.VerticalAlignment = xlTop
    tbl.ListColumns(21).Range.HorizontalAlignment = xlLeft

Else
    ' Find the last used table name and increment it for the new table
    Dim lastTableName As String
    Dim newTableName As String
    Dim lastNumber As Integer
    Dim newNumber As Integer
    
    
    'unhide columns F to M
    ws.Range("F:M").EntireColumn.Hidden = False

    'unhide columns O to T
    ws.Range("O:T").EntireColumn.Hidden = False
    
    For Each existingTable In Sheets(sheetName).ListObjects
        If Left(existingTable.Name, 9) = "tblUpdate" Then
            lastTableName = existingTable.Name
            lastNumber = Val(Right(lastTableName, 3))
            lastRow = existingTable.Range.Rows(existingTable.Range.Rows.Count).Row
            Exit For
        End If
    Next existingTable

    newNumber = lastNumber + 1
    newTableName = "tblUpdate" & Format(newNumber, "000")

    ' Determine the range for the new table
    Dim startRow As Long
    startRow = lastRow + 2 ' Add 2 to account for the blank row and header row
    Dim newTableRange As Range
    Set newTableRange = Sheets(sheetName).Range("A" & startRow).CurrentRegion

    ' Convert the new data on "sheetName" to a table with the incremented table name
    Dim newTbl As ListObject
    Set newTbl = Sheets(sheetName).ListObjects.Add(xlSrcRange, newTableRange, , xlYes)
    newTbl.Name = newTableName

    ' Apply table formatting
    With newTbl
        .TableStyle = "TableStyleLight2" ' Modify the table style as desired
        .ShowTableStyleFirstColumn = False
        .ShowTableStyleLastColumn = False
    End With
    
    Set newCol = newTbl.ListColumns.Add(Position:=21)
    newCol.Name = "CoA Review of Change"
    
    ' Auto-fit the column widths in the table
    newTbl.Range.Columns.AutoFit
    
    newTbl.ListColumns(21).Range.ColumnWidth = 60
    newTbl.ListColumns(21).Range.Font.Size = 10
    newTbl.ListColumns(21).Range.WrapText = True
    newTbl.ListColumns(21).Range.VerticalAlignment = xlTop
    newTbl.ListColumns(21).Range.HorizontalAlignment = xlLeft
    
    lastRowTbl = newTbl.Range.Rows.Count
    If lastRowTbl > 1 Then
        newTbl.Range.Rows("2:" & lastRowTbl).Group
    End If
    
    'unhide columns F to M
    ws.Range("F:M").EntireColumn.Hidden = True

    'unhide columns O to T
    ws.Range("O:T").EntireColumn.Hidden = True
    
End If


Application.DisplayAlerts = False
wb.Sheets("Import").Delete
wb.Sheets(1).UsedRange.Font.Size = 10
wb.Sheets(1).UsedRange.Font.Color = RGB(0, 0, 0)
Application.DisplayAlerts = True

    wsOld.Sort.SortFields.Clear
    wsOld.Sort.SortFields.Add Key:=wsOld.Range("A2:A" & lastRowOrig), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    wsOld.Sort.SortFields.Add Key:=wsOld.Range("B2:B" & lastRowOrig), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    wsOld.Sort.SortFields.Add Key:=wsOld.Range("C2:C" & lastRowOrig), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With wsOld.Sort
        .SetRange wsOld.Range("A1:T" & lastRowOrig)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    ActiveWindow.SmallScroll Down:=-57
    Columns("F:M").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Columns("N:N").Select
    With Selection
        .WrapText = True
    End With
    Columns("O:P").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Columns("Q:Q").Select
    With Selection
        .WrapText = True
    End With
    Columns("R:R").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Columns("S:S").Select
    With Selection
        .WrapText = True
    End With
    
    wsOld.Range("A1").Select

End Sub

 

[Killragtshirts]

Nice!!! Glad you sorted it.