将工作表从文件夹中分组的多个工作簿复制到主文件

Question

我目前在我的桌面上有一个名为 Files 的文件夹，其中包含多个彼此相似的工作簿，例如：

• 工作簿1
• 工作簿2
• 工作簿3
• 工作簿4
• 工作簿5

这些工作簿中的每一个都包含一个名为“仪表板”的工作表，它们彼此相同，但它们为不同的人提供不同的数据。

我想做的是：

• 运行一个宏，将所有名为“仪表板”的工作表导入到我现在打开的新工作簿中。
• 以导入的文件命名每个导入的工作表。

我对此进行了研究，尽管已经提供了许多解决方案，但我发现最接近我需要的代码是：

Sub MergeWorkbooks()

Dim xStrPath As String
Dim xStrFName As String
Dim xWS As Worksheet
Dim xMWS As Worksheet
Dim xTWB As Workbook
Dim xStrAWBName As String
On Error Resume Next
xStrPath = "C:\Users\Me\Desktop\Files"
xStrFName = Dir(xStrPath & "*.xlsx")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set xTWB = ThisWorkbook
Do While Len(xStrFName) > 0
    Workbooks.Open Filename:=xStrPath & xStrFName, ReadOnly:=True
    xStrAWBName = ActiveWorkbook.Name
    For Each xWS In ActiveWorkbook.Sheets
    xWS.Copy After:=xTWB.Sheets(xTWB.Sheets.Count)
    Set xMWS = xTWB.Sheets(xTWB.Sheets.Count)
    xMWS.Name = xStrAWBName & "(" & xMWS.Name & ")"
    Next xWS
    Workbooks(xStrAWBName).Close
    xStrFName = Dir()
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

当我尝试运行它时，没有遇到任何错误，也没有任何反应。有谁知道为什么会这样？

提前致谢

Answer 1

未经测试：

Sub MergeWorkbooks()

    Dim xStrPath As String
    Dim xStrFName As String
    Dim xWS As Worksheet
    Dim xMWS As Worksheet
    Dim xTWB As Workbook, wb As Workbook
    Dim xStrAWBName As String

    xStrPath = "C:\Users\Me\Desktop\Files\" '<< add final \
    xStrFName = Dir(xStrPath & "*.xlsx")

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Set xTWB = ThisWorkbook 

    Do While Len(xStrFName) > 0
        Set wb = Workbooks.Open(Filename:=xStrPath & xStrFName, ReadOnly:=True) '<< get a direct reference
        'copy only the specific sheet
        wb.Worksheets("Dashboard").Copy after:=xTWB.Sheets(xTWB.Sheets.Count)
        xTWB.Sheets(xTWB.Sheets.Count).Name = Replace(xStrFName, ".xlsx", "")
        wb.Close False 'don't save
        xStrFName = Dir()
    Loop

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub