我是VBA的新手,我正在尝试将数据从一个工作簿复制到另一个工作簿。在我的“复制工作簿” wb1(.dbf格式)中,我要复制3组数据到我的“粘贴工作簿” wb2(.xlsm格式)。
我需要将一个数据块的三个“块”(我称为带)复制到另一个WB。 Band1的范围是“ C2:M5”,Band2的范围是“ N2:X5”,Band3的范围是“ Y2:AI5”。
我希望用户能够选择他要粘贴每个频段的位置,理想情况下,是让用户仅选择每个频段范围的第一个单元格。
到目前为止,我的代码如下所示。它一次只能复制和粘贴一个带,这意味着我必须运行三遍。我的目标是要有一个例程,可以一次复制并粘贴所有数据(运行一次代码),并在用户希望的时候粘贴带/“块”。
我希望这足够清楚。预先感谢您的所有帮助!
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
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