從不同的工作簿復制數據並將其粘貼到報表工作簿上的特定工作表

Question

目前我是新研究 VBA 以進行報告，我仍在從中學習。 繼續前進，我可以在這個方面尋求幫助嗎？ :)，我的情況是這樣的。

• 我有 20 個工作簿（POLY、BAYO、PROPO、TIPAS、CITRO 等）的數據，工作表名稱為（Sheet1）
• 我有一個包含許多工作表的摘要工作簿，其工作表名稱基於 20 個工作簿文件名，但不按字母順序排列。 （工作表名稱 = CITRO、BAYO、PROPO、POLY、TIPAS....等）
• 我想復制每個工作簿上的數據並根據文件名和特定單元格（“B2：F2”）將其粘貼到各自的工作表名稱
• 可行嗎？

這是我試圖處理的代碼，問題是，它正在創建自己的工作表，而不是將其粘貼到我想要的工作表上。

---

Private Sub CommandButton1_Click()

Dim SourceBook As Workbook   
Dim CurrentBook As Workbook

application.screenupdating = false
Set CurrentBook = ThisWorkbook

Set SourceBook = Workbooks.Open("C:\CITRO.xlsx")
SourceBook.Sheets("Sheet1").Range("B2:F2").Copy Destination:=CurrentBook.Sheets("CITRO").Range("R2:V2")

Set SourceBook = Workbooks.Open("C:\BAYO.xlsx")
SourceBook.Sheets("Sheet1").Range("B2:F2").Copy Destination:=CurrentBook.Sheets("BAYO").Range("R2:V2")

Set SourceBook = Workbooks.Open("C:\PROPO.xlsx")
SourceBook.Sheets("Sheet1").Range("B2:F2").Copy Destination:=CurrentBook.Sheets("PROPO").Range("R2:V2")

MsgBox "Completed"
Application.Workbooks("CITRO").Close
Application.Workbooks("BAYO").Close
Application.Workbooks("PROPO").Close
'SourceBook.Close
'Set SourceBook = Nothing
'Set CurrentBook = Nothing

'ThisWorkbook.Activate
'Application.Worksheets("Summary").Activate
'Application.Worksheets("Summary").Range("B2:F2").Select

End Sub

Answer 1

您需要先關閉SourceBook ，然后再使用SourceBook.Close SaveChanges:=False打開一個新的

Private Sub CommandButton1_Click()
    Dim SourceBook As Workbook   
    Dim CurrentBook As Workbook

    Application.ScreenUpdating = False 'don't forget to activate it in the end
    Set CurrentBook = ThisWorkbook

    Set SourceBook = Workbooks.Open("C:\CITRO.xlsx")
    SourceBook.Worksheets("Sheet1").Range("B2:F2").Copy Destination:=CurrentBook.Worksheets("CITRO").Range("R2:V2")
    SourceBook.Close SaveChanges:=False

    Set SourceBook = Workbooks.Open("C:\BAYO.xlsx")
    SourceBook.Worksheets("Sheet1").Range("B2:F2").Copy Destination:=CurrentBook.Worksheets("BAYO").Range("R2:V2")
    SourceBook.Close SaveChanges:=False

    Set SourceBook = Workbooks.Open("C:\PROPO.xlsx")
    SourceBook.Worksheets("Sheet1").Range("B2:F2").Copy Destination:=CurrentBook.Worksheets("PROPO").Range("R2:V2")
    SourceBook.Close SaveChanges:=False

    Application.ScreenUpdating = True        
    MsgBox "Completed"
End Sub

---

或者，您可以使用一個過程來縮短它：

Private Sub CommandButton1_Click()        
    Application.ScreenUpdating = False 'don't forget to activate it in the end

    CopyIntoThisWorkbook "C:\CITRO.xlsx", "CITRO"
    CopyIntoThisWorkbook "C:\BAYO.xlsx", "BAYO"
    CopyIntoThisWorkbook "C:\PROPO.xlsx", "PROPO"

    Application.ScreenUpdating = True        
    MsgBox "Completed"
End Sub


Private Sub CopyIntoThisWorkbook(ByVal SourceFileName As String, ByVal DestinationSheetName As Range)
    Dim SourceBook As Workbook
    Set SourceBook = Workbooks.Open(SourceFileName)
    SourceBook.Worksheets("Sheet1").Range("B2:F2").Copy Destination:=ThisWorkbook.Worksheets(DestinationSheetName).Range("R2:V2")
    SourceBook.Close SaveChanges:=False
End Sub

---

如果工作表名稱CITRO始終是文件名CITRO.xlsx那么您甚至可以使用帶有循環的數組：

Private Sub CommandButton1_Click()        
    Application.ScreenUpdating = False 'don't forget to activate it in the end
    Dim SheetNameList() As Variant
    SheetNameList = Array("CITRO", "BAYO", "PROPO") 'easily extendable

    Dim SheetName As Variant
    For Each SheetName In SheetNameList
        CopyIntoThisWorkbook SheetName
    Next SheetName

    Application.ScreenUpdating = True        
    MsgBox "Completed"
End Sub


Private Sub CopyIntoThisWorkbook(ByVal DestinationSheetName As String)
    Dim SourceBook As Workbook
    Set SourceBook = Workbooks.Open("C:\" & DestinationSheetName & ".xlsx")
    SourceBook.Worksheets("Sheet1").Range("B2:F2").Copy Destination:=ThisWorkbook.Worksheets(DestinationSheetName).Range("R2:V2")
    SourceBook.Close SaveChanges:=False
End Sub