Копирование листа из нескольких рабочих книг, сгруппированных в папке, в главный файл

Question

В настоящее время у меня на рабочем столе есть папка Files, содержащая несколько рабочих книг, которые похожи друг на друга, например:

• Workbook1
• Workbook2
• Рабочая тетрадь3
• Рабочая тетрадь4
• Рабочая тетрадь5

Каждая из этих рабочих книг содержит лист под названием «Панель инструментов», которые совпадают друг с другом, но содержат разные данныедля разных людей.

Я хотел бы сделать следующее:

• Запустить макрос, который будет импортировать все листы с именем «Панель инструментов» в новую открытую книгу, которую я сейчас открыл.
• Назовите каждый импортированный лист после файла, из которого он был импортирован.

Я исследовал это, и хотя было предложено много решений, наиболее близкий код, который я нашел, выполняет то, что мне нужноis:

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