如何使用 VBA 使用来自其他 excel 文件的新数据覆盖数据库中的数据？

Question

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!

Answer 1

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