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

Answer 1

在嘗試將 dws 設置為工作表之前，您忘記打開工作簿。 此外，由於“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量並不是推進 output 范圍的最佳方式，因為它可能會在您的數據中留下大量空白行。 最好用dws.Cells(dws.Rows.Count, 1).End(xlUp).Offset(1)重新設置 dCell