如何使用 VBA 使用来自其他 excel 文件的新数据覆盖数据库中的数据?
How to overwrite the data in database with new data coming from other excel files using VBA?
我想使用 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
并将数据传输到主文件时,它将创建第 4 行而不是更新第 3 行中的数据。我可以知道我应该如何修改我的脚本,以便只要日期相同,它就会更新现有行而不是创建新行吗?任何帮助将不胜感激!
它可能如下所示。我简化了例子。
请注意,我建议不要使用 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
我想使用 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
并将数据传输到主文件时,它将创建第 4 行而不是更新第 3 行中的数据。我可以知道我应该如何修改我的脚本,以便只要日期相同,它就会更新现有行而不是创建新行吗?任何帮助将不胜感激!
它可能如下所示。我简化了例子。
请注意,我建议不要使用 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