VBA将一个工作簿中的数据复制到另一个工作簿中

Question

我浏览了网页以寻找答案但找不到帮助。我要做的是打开一个工作簿并将数据从“数据”选项卡（B2到I2）复制到我的主工作簿“注册”选项卡下。问题是我需要将数据粘贴到相应的引用上。在我打开的工作簿中，引用是在A2中，在现有工作簿中，它需要查找的引用位于A列中。

我设法编写了一个代码，将数据粘贴到引用的行号中，但这并不好，因为它必须是它在查找和粘贴的列A中的实际值。

任何想法将不胜感激！

Sub Import()
Dim WB2op As String, CurWB As Workbook, WB2 As Workbook, nextrow As Long
Dim Row As Long
Dim ws As Worksheet
Set ws = Worksheets("Register")
Set CurWB = ThisWorkbook
WB2op = Application.GetOpenFilename _
(Title:="Please choose File", _
FileFilter:="Excel Files *.xlsx* (*.xlsx*),")
If WB2op = "False" Then
    MsgBox "No file selected.", vbExclamation
    Exit Sub
Else
Set WB2 = Workbooks.Open(WB2op)
With Sheets("Data")    'change name to suit
    .Visible = xlSheetVisible
    .Activate
    .Range("A1").Select
End With

If WB2.Sheets("Data").Range("A2") >= 0 Then
Row = WB2.Sheets("Data").Range("A2") + 1
End If

Application.ScreenUpdating = False
ws.Range("N" & Row).Value = WB2.Sheets("Data").Range("B2")
ws.Range("O" & Row).Value = WB2.Sheets("Data").Range("C2")
ws.Range("P" & Row).Value = WB2.Sheets("Data").Range("D2")
ws.Range("Q" & Row).Value = WB2.Sheets("Data").Range("E2")
ws.Range("R" & Row).Value = WB2.Sheets("Data").Range("F2")
ws.Range("S" & Row).Value = WB2.Sheets("Data").Range("G2")
ws.Range("T" & Row).Value = WB2.Sheets("Data").Range("H2")
ws.Range("U" & Row).Value = WB2.Sheets("Data").Range("I2")
Application.CutCopyMode = False
Application.ScreenUpdating = True
End If

WB2.Close False
End Sub

Answer 1

我通过添加MATCH选项来管理它，如下所示：

Sub Import()
Dim WB2op As String, CurWB As Workbook, WB2 As Workbook, nextrow As Long
Dim Row As Long
Dim ws As Worksheet
Set ws = Worksheets("Register")
Set CurWB = ThisWorkbook
WB2op = Application.GetOpenFilename _
(Title:="Please choose File", _
FileFilter:="Excel Files *.xlsx* (*.xlsx*),")
If WB2op = "False" Then
    MsgBox "No file selected.", vbExclamation
    Exit Sub
Else
Set WB2 = Workbooks.Open(WB2op)
With Sheets("Data")    'change name to suit
    .Visible = xlSheetVisible
    .Activate
    .Range("A1").Select
End With

If WB2.Sheets("Data").Range("A2") >= 0 Then
On Error Resume Next
Row = Application.WorksheetFunction.Match(WB2.Sheets("Data").Range("A2"), ws.Range("A:A"), 0)
On Error GoTo 0

End If

Application.ScreenUpdating = False
ws.Range("N" & Row).Value = WB2.Sheets("Data").Range("B2")
ws.Range("O" & Row).Value = WB2.Sheets("Data").Range("C2")
ws.Range("P" & Row).Value = WB2.Sheets("Data").Range("D2")
ws.Range("Q" & Row).Value = WB2.Sheets("Data").Range("E2")
ws.Range("R" & Row).Value = WB2.Sheets("Data").Range("F2")
ws.Range("S" & Row).Value = WB2.Sheets("Data").Range("G2")
ws.Range("T" & Row).Value = WB2.Sheets("Data").Range("H2")
ws.Range("U" & Row).Value = WB2.Sheets("Data").Range("I2")
Application.CutCopyMode = False
Application.ScreenUpdating = True
End If

WB2.Close False End Sub