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)
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.