VBA Macro to detect unique entries and copy them from one workbook to another is copying a small fraction of duplicates along with the uniques

Question

I have a workbook that contains a table with many columns of data, each entry being identified as unique through a unique ID string in column 1. We have two copies of this workbook, one at our home office, and one on a server in a truck for when we are on the move. I know this is not the optimal situation, and this workbook should and will be moved to a proper database solution eventually, but for now I have to work with what I have.

The problem I need to solve is quickly being able to sync these workbooks to each other, copying the unique values from one to the other and vice versa. My plan was to create a VBA macro that looks for entries in the other workbook that aren't in the current workbook, and copy those over. Then the same macro would be run on the other workbook to make sure all entries are on both workbooks.

Here is the code that I have tried

Sub SyncFromWorkbook()
    Dim thisWorksheet As Excel.Worksheet
    Dim syncWorksheet As Excel.Worksheet
    Set thisWorksheet = Application.ActiveSheet
    Set syncWorksheet = Workbooks("workbook2.xlsm").Sheets("Archive")
    
    Dim thisLastRow As Long
    Dim syncLastRow As Long
    Dim thisLastColumn As Long
    Dim syncLastColumn As Long
    thisLastRow = thisWorksheet.Cells(Rows.Count, 1).End(xlUp).Row
    syncLastRow = syncWorksheet.Cells(Rows.Count, 1).End(xlUp).Row
    thisLastColumn = thisWorksheet.Cells(6, Columns.Count).End(xlToLeft).Column
    syncLastColumn = syncWorksheet.Cells(6, Columns.Count).End(xlToLeft).Column
    
    Dim thisRange As Range
    Dim syncRange As Range
    Set thisRange = thisWorksheet.Range("A6", thisWorksheet.Cells(thisLastRow, thisLastColumn))
    Set syncRange = syncWorksheet.Range("A6", syncWorksheet.Cells(syncLastRow, syncLastColumn))
    
    Dim copyRows As New Collection
    Set copyRows = UniqueRows(thisRange, syncRange)
    
    Dim rowIndex As Long
    rowIndex = thisLastRow + 1
    For Each r In copyRows
        syncWorksheet.Range(syncWorksheet.Cells(r, 1), syncWorksheet.Cells(r, syncLastColumn)).Copy
        thisWorksheet.Cells(rowIndex, 1).Select
        thisWorksheet.Paste
        rowIndex = rowIndex + 1
    Next r
End Sub

Function UniqueRows(thisRange As Range, syncRange As Range) As Collection
    Dim uniqueRowsColl As New Collection
    
    For i = 1 To syncRange.Rows.Count
        Dim matchingRow As Boolean
        
        For j = 1 To thisRange.Rows.Count
            If syncRange.Cells(i, 1) = thisRange.Cells(j, 1) Then
                matchingRow = True
            End If
        Next j
        
        If matchingRow = False Then
            uniqueRowsColl.Add (i)
        End If
        matchingRow = False
    Next i
    
    Set UniqueRows = uniqueRowsColl
End Function

For the most part, this works. The problem is when I run this macro, around 30 entries that get copied over out of about 200 end up being duplicates that aren't caught. That is, they are entries that are already in the first workbook that shouldn't have been copied from the second one. If I run the macro again, those same ~30 rows get copied again and none of the others do (which is the expected behavior)

Answer 1

The ranges being compared start at Row 6 but your values of i in UniqueRows are all 1-based.

Instead something like this:

syncRange.Rows(r).Copy thisWorksheet.Cells(rowIndex, 1)

should work.