VBA将一个文件夹中多个工作簿的范围复制到另一个文件夹

Question

我在文件夹A中有10个excel文件。我在文件夹B中还有其他10个excel。两个文件夹中的10个文件同名。我正试图将活动工作表的范围A2:B20从文件夹A中的10个excel文件中的每一个复制到文件夹B中的其他10个相应excel文件中。文件夹B中所有文件只有一个名为Sheet0的工作表。我想在文件夹B中的每个excel文件中，在Sheet0的A列和B列的末尾都有A2:B20的范围。

下面是我的代码。我已经尝试了很多次，但它不起作用

Sub Copy_range()

Const FolderPath1 = "C:Users***DocumentsFolder A"
Const FolderPath2 = "C:Users***DocumentsFolder B"

Dim Filename1 As String: Filename1 = Dir(FolderPath1 & "*.csv")
Dim Filename2 As String: Filename2 = Dir(FolderPath2 & "*.xlsx")

Dim dws As Worksheet: Set dws = Workbooks(Filename2).Worksheets("Sheet0")
Dim dCell As Range: Set dCell = dws.Cells(dws.Rows.Count, "A1:B").End(xlUp)

Application.ScreenUpdating = False
Do While Filename1 <> ""
Set dCell = dCell.Offset(1)
With Workbooks.Open(Filename1:=FolderPath1 & Filename1, ReadOnly:=True)
dCell.Value = .ActiveSheet.Range("A2:B20").Value
.Close False
End With
Filename1 = Dir()
Loop
Application.ScreenUpdating = True
End Sub

Answer 1

在尝试将dws设置到工作表之前，您忘记打开工作簿。此外，要设置dCell的表达式将由于"；A1:B"；不是有效的列输入。最后，dCell的.Offset(1)将只在第一次迭代中工作。之后，您将想要.Offset(19)，因为您已经粘贴了19个新行。我已经在以下代码中更正了这三个问题：

Sub Copy_range()

Const FolderPath1 = "C:Users***DocumentsFolder A"
Const FolderPath2 = "C:Users***DocumentsFolder B"

Dim Filename1 As String: Filename1 = Dir(FolderPath1 & "*.csv")
Dim Filename2 As String: Filename2 = Dir(FolderPath2 & "*.xlsx")

Dim dws As Worksheet
Dim dCell As Range
Set dws = Application.Workbooks.Open(FolderPath2 & Filename2).Worksheets("Sheet0")
Set dCell = dws.Cells(dws.Rows.Count, 1).End(xlUp).Offset(1)

Application.ScreenUpdating = False
Do While Filename1 <> ""
With Workbooks.Open(FolderPath1 & Filename1, ReadOnly:=True)
dCell.Value = .ActiveSheet.Range("A2:B20").Value
.Close False
End With
Filename1 = Dir()
Set dCell = dCell.Offset(19)
Loop
Application.ScreenUpdating = True
End Sub

事实上，Offset并不是提高输出范围的最佳方式，因为它可能会在数据中留下很多空白行。最好只是用dws.Cells(dws.Rows.Count, 1).End(xlUp).Offset(1)重新设置dCell