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

Question

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

下面是我的代码。我试了很多次都没用

Sub Copy_range()
    
    Const FolderPath1 = "C:\Users\***\Documents\Folder A\"
    Const FolderPath2 = "C:\Users\***\Documents\Folder 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 设置为 sheet 之前忘记打开工作簿。此外，由于“A1:B”不是有效的列输入，设置 dCell 的表达式会导致错误。最后，dCell 的 .Offset(1) 只会在第一次迭代时起作用。之后，您需要 .Offset(19) 因为您已经粘贴了 19 行新行。我已在以下代码中更正了这三个问题：

Sub Copy_range()
    
    Const FolderPath1 = "C:\Users\***\Documents\Folder A\"
    Const FolderPath2 = "C:\Users\***\Documents\Folder 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

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

VBA to copy a range from multiple workbooks in a folder into another folder

excel

vba

copy

range

worksheet