I want to send the data from my source files to Main File using VBA. This is my script:
Sub TransferData()
Dim main_wb As Workbook, target_wb As Workbook, main_sheet As String
Dim r As String, target_sheet As String, first_col As Byte, col_n As Byte
Dim next_row As Long, duplicates As Byte, pasted As Byte, last_col As Long
'CONFIG HERE
'------------------------
Set main_wb = ThisWorkbook
main_sheet = "Sheet1"
r = "B6:G6" 'range to copy in the main Workbook
'target workbook path
Set target_wb = Workbooks("Main File.xlsm")
'Workbooks.Open ("/Users/user/Desktop/target workbook.xlsm")
target_sheet = "DataBase"
first_col = 2 'in what column does the data starts in target sheet?
'-------------------------
'turn screen updating off
Application.ScreenUpdating = False
'copy from main
main_wb.Sheets(main_sheet).Range(r).Copy
With target_wb.Sheets(target_sheet)
'target info
next_row = _
.Cells(Rows.Count, first_col).End(xlUp).Row + 1
'paste in target
.Cells(next_row, first_col).PasteSpecial Paste:=xlPasteValues
last_col = _
.Cells(next_row, Columns.Count).End(xlToLeft).Column
End With
pasted = last_col - (first_col - 1)
For col_n = first_col To last_col
With target_wb.Sheets(target_sheet)
If .Cells(next_row, col_n) = .Cells(next_row - 1, col_n) Then
duplicates = duplicates + 1
End If
End With
Next col_n
If duplicates = pasted Then 'if the nº of cells pasted equals duplicates
For col_n = first_col To last_col 'erase pasted range
target_wb.Sheets(target_sheet).Cells(next_row, col_n).Clear
Next col_n
End If
'turn screen updating back on
Application.ScreenUpdating = True
End Sub
If the previous row in Main File is exactly the same as the new row data coming from source file, the script able to prevent the data been pasted in the Main File again. However, once there are some new update in source file and the data been transferred again, the script will treat it as new row instead of updating the existing row. The 1st screenshot below is the data in source file and the 2nd screenshot is the database in Main File:
As you can see on the screenshot above, when I update the cell C6
in source file and transfer the data to the Main File, it will create Row4 instead of updating the data in Row3. May I know how should I modified my script so that it will updating the existing row instead of creating the new row as long as the date are the same? Any help will be greatly appreciated!
It could look like below. I simplified the example.
Note that instead of using InputSheet.Range("B6:G6")
I recommend to give the range B6:G6
a name like InputRange
and then use InputSheet.Range("InputRange")
. So you don't need to touch the code again if you add a column for example.
Option Explicit
Public Sub TransferData()
Dim InputSheet As Worksheet ' set data input sheet
Set InputSheet = ThisWorkbook.Worksheets("Input")
Dim InputRange As Range ' define input range
Set InputRange = InputSheet.Range("B6:G6") ' I recomend a named range instead!
Dim TargetSheet As Worksheet
Set TargetSheet = ThisWorkbook.Worksheets("Target") ' Define your Target Workbooks("Main File.xlsm").Worksheets("DataBase")
Const TargetStartCol As Long = 2 ' start pasting in this column in target sheet
Const PrimaryKeyCol As Long = 1 ' this is the unique primary key in the input range (means first column of B6:G6 is primary key)
Dim InsertRow As Long ' this will be the row to insert
' first we try to find a row with the same primary key to replace
On Error Resume Next ' next row will error if no match is found, so hide error messages
' match primary key of data input with target
InsertRow = Application.WorksheetFunction.Match(InputRange.Cells(1, 1), TargetSheet.Columns(TargetStartCol + PrimaryKeyCol - 1), 0)
On Error GoTo 0 're-enable error messages!
If InsertRow = 0 Then ' if no matching primary key was found
' insert in the next empty row in the end
InsertRow = TargetSheet.Cells(TargetSheet.Rows.Count, TargetStartCol + PrimaryKeyCol - 1).End(xlUp).Row + 1
End If
' copy values to target row
TargetSheet.Cells(InsertRow, TargetStartCol).Resize(ColumnSize:=InputRange.Columns.Count).Value = InputRange.Value
End Sub