-1

在以下方面略有挣扎..如果有人可以提供帮助，那就太棒了！

我有一个文件夹，每个文件夹都包含不同的 excel 文件，一致命名为“Provider A Product X Month Year”，每个文件夹仅包含一张表或标准表 1、..、表 3

现在我很想将所有这些工作簿（如果工作簿中有多个工作表，则只有第一个工作表）合并为一个，并将所有工作表重命名为“月年”，与各自的原始文件名相同。我已经看到将几个工作簿合并到一个工作簿中，所有工作簿都作为工作表，这部分有帮助，但没有完全回答..

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

任何想法都非常感谢！

谢谢马库斯

4

1 回答 1

1

试试这个：

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
于 2013-08-08T18:54:52.643 回答