如何使用 VBA 使用來自其他 excel 文件的新數據覆蓋數據庫中的數據？

Question

我想使用 VBA 將源文件中的數據發送到主文件。 這是我的腳本：

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

如果主文件中的前一行與來自源文件的新行數據完全相同，則腳本能夠防止數據再次粘貼到主文件中。 但是，一旦源文件中有一些新的更新並且數據再次傳輸，腳本會將其視為新行而不是更新現有行。 下面的第一張截圖是源文件中的數據，第二張截圖是主文件中的數據庫：

正如您在上面的屏幕截圖中看到的，當我更新源文件中的單元格C6並將數據傳輸到主文件時，它將創建 Row4 而不是更新 Row3 中的數據。 我可以知道我應該如何修改我的腳本，以便只要日期相同，它就會更新現有行而不是創建新行？ 任何幫助將不勝感激！

Answer 1

它可能如下所示。 我簡化了這個例子。

請注意，我建議不要使用InputSheet.Range("B6:G6")為范圍B6:G6命名，例如InputRange ，然后使用InputSheet.Range("InputRange") 。 因此，例如，如果您添加一列，則無需再次觸摸代碼。

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