Excel 将工作簿合并到文件夹中，并将图纸重命名为以前的文件名

在以下方面有点困难。。如果有人能帮上忙，那就太棒了

我有一个文件夹，每个文件夹包含不同的excel文件，一致命名为“供应商a产品X月-年”，每个文件夹仅包含一张表或标准表1、…、表3

现在，我希望将所有这些工作簿（如果工作簿中有多个工作表，则仅第一个工作表）合并为一个，并将所有工作表重命名为“月-年”，与各自的原始名称相同。我已经看到了部分有帮助但不能完全回答的答案

或者，甚至更好，最好将所有文件合并到同一工作表中，在彼此下面，并将文件名的“月-年”部分作为一个额外的列。也就是说，如果我在A1:D50中有数据，则宏将添加一个新列a，并将“月-年”写入A1:A50中的每个列

任何想法都非常感谢

谢谢 马库斯试一试：

Sub tgr()

    Dim wsDest As Worksheet
    Dim oShell As Object
    Dim strFolderPath As String
    Dim strFileName As String
    Dim strMonthYear As String

    Set oShell = CreateObject("Shell.Application")
    On Error Resume Next
    strFolderPath = oShell.BrowseForFolder(0, "Select Folder", 0).Self.Path & Application.PathSeparator
    Set oShell = Nothing
    On Error GoTo 0
    If Len(strFolderPath) = 0 Then Exit Sub 'Pressed cancel

    Application.ScreenUpdating = False
    Set wsDest = Sheets.Add(After:=Sheets(Sheets.Count))
    wsDest.Range("A1").Value = "Month Year"
    strFileName = Dir(strFolderPath & "*.xls*")

    Do While Len(strFileName) > 0
        With Workbooks.Open(strFolderPath & strFileName)
            .Sheets(1).UsedRange.Copy wsDest.Cells(Rows.Count, "B").End(xlUp).Offset(1)
            .Close False
        End With
        strMonthYear = WorksheetFunction.Trim(Right(Replace(strFileName, " ", String(99, " ")), 198))
        wsDest.Range(wsDest.Cells(Rows.Count, "A").End(xlUp).Offset(1), wsDest.Cells(Rows.Count, "B").End(xlUp).Offset(, -1)).Value = strMonthYear
        strFileName = Dir
    Loop
    Application.ScreenUpdating = True

    Set wsDest = Nothing

End Sub