合并工作簿在文件夹中并将工作表重命名为以前的文件名

时间:2013-08-08 18:14:31

标签: excel-vba vba excel

如果有人能提供帮助,那么稍微挣扎以下......会很棒!!

我有一个文件夹,每个文件夹包含一致名为“Provider A Product X Month Year”的不同excel文件,每个文件夹只包含一个工作表或标准工作表1,..,工作表3

现在我希望将所有这些工作簿(只有工作簿中的多张工作表中的第一张工作表)合并为一个工作簿,并将所有工作表重命名为“月份年”,与相应的原始文件名相同。我见过Merging Several Workbooks Into One Workbook with All the Workbooks as Sheets部分有帮助,但没有完全回答..

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

非常感谢任何想法!

由于 马库斯

1 个答案:

答案 0 :(得分: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