将不同工作簿中的数据复制并粘贴到多个单元格

Question

我是 VBA 新手，我正在尝试将数据从一个工作簿复制到另一个工作簿。在我的“复制工作簿”中，wb1（.dbf 格式）我有 3 组数据要复制到我的“粘贴工作簿”中，wb2（.xlsm 格式）。

我需要将数据的三个“块”（我称之为波段）从一个 WB 复制到另一个。 Band1 的范围是“C2:M5”，Band2 的范围是“N2:X5”，Band3 的范围是“Y2:AI5”。

我希望用户能够选择粘贴每个波段的位置，理想情况下是让他只选择每个波段范围的第一个单元格。

到目前为止，我的代码如下所示。它一次只能复制和粘贴一个波段，这意味着我必须运行它 3 次。我的目标是有一个例程，它可以一次复制和粘贴所有数据（运行一次代码），并在用户想要它们时粘贴带/“块”。

我希望这已经足够清楚了。提前感谢您的所有帮助！

Sub CopyData()

' Keyboard shortcut: Ctrl+d

Dim band As Integer
Dim wb1 As Workbook
Dim wb2 As Workbook

Set band = InputBox("Choose bands 1, 2 or 3:")

Set wb1 = Workbooks.Open("C:\Users\mmm\CopyFile.dbf") ' File I want to copy the data from
Set wb2 = Workbooks.Open("C:\Users\mmm\PasteFile.xlsm") ' File I want to paste my data to

If band = 1 Then

    wb1.Worksheets(dbf_name).Range("C2:M5").Copy 'Range of Band1 to copy
    wb1.Close savechanges:=False
    Application.DisplayAlerts = True

    Application.DisplayAlerts = False
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Range("A1").Select

ElseIf band = 2 Then

    wb1.Worksheets(dbf_name).Range("N2:X5").Copy 'Range of Band2 to copy
    wb1.Close savechanges:=False
    Application.DisplayAlerts = True

    Application.DisplayAlerts = False
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Range("A1").Select

ElseIf band = 3 Then

    wb1.Worksheets(dbf_name).Range("Y2:AI5").Copy 'Range of Band3 to copy
    wb1.Close savechanges:=False
    Application.DisplayAlerts = True

    Application.DisplayAlerts = False
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Range("A1").Select

End If
End Sub

[使用最终代码更新]

Sub CopyData()

' Keyboard shortcut: Ctrl+d

Dim dbf_path As String
Dim dbf_name As String
Dim rCopy As Range
Dim i As Long
Dim rPaste As Range
Dim wb1 As Workbook

dbf_path = "C:\Users\mmm\CopyFile.dbf"
dbf_name = "filename_dbf"
Set wb1 = Workbooks.Open(dbf_path)

ThisWorkbook.Activate

Set rCopy = wb1.Worksheets(dbf_name).Range("C2:M5,N2:X5,Y2:AI5")

For i = 1 To rCopy.Areas.Count 'loop through each distinct block or area
    Set rPaste = Application.InputBox("Enter starting cell for range " & i, Type:=8) 'invite paste cell, specifying range input
    If rPaste.Count > 1 Then Set rPaste = rPaste(1) 'if more than one cell selected use the first one
    rCopy.Areas(i).Copy rPaste 'paste
Next i

wb1.Close savechanges:=False

End Sub

Answer 1

这里有一个简单的例子来展示如何通过输入框为每个块设置粘贴目标。希望您可以根据自己的精确设置对其进行调整。

Sub x()

Dim rCopy As Range, i As Long, rPaste As Range

Set rCopy = Range("C2:M5,N2:X5,Y2:AI5") 'define ranges to copy

For i = 1 To rCopy.Areas.Count 'loop through each distinct block or area
    Set rPaste = Application.InputBox("Enter starting cell for range " & i, Type:=8) 'invite paste cell, specifying range input
    If rPaste.Count > 1 Then Set rPaste = rPaste(1) 'if more than one cell selected use the first one
    rCopy.Areas(i).Copy rPaste 'paste
Next i

End Sub