从不同的工作簿复制数据并将其粘贴到报表工作簿上的特定工作表

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