excel - 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\***\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

标签： excelvbacopyrangeworksheet

Answer 1

在尝试将 dws 设置为工作表之前，您忘记打开工作簿。此外，由于“A1:B”不是有效的列输入，您设置 dCell 的表达式会导致错误。最后，.Offset(1)dCell 只在第一次迭代时起作用。之后，你会想要，.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这不是提高输出范围的最佳方法，因为它可能会在数据中留下大量空白行。重新设置 dCell 会更好dws.Cells(dws.Rows.Count, 1).End(xlUp).Offset(1)