将多个工作簿合并为一个工作簿，所有工作簿为工作表

Posted 2023-04-13

【中文标题】将多个工作簿合并为一个工作簿，所有工作簿为工作表

【英文标题】：Merging Several Workbooks Into One Workbook with All the Workbooks as Sheets

【发布时间】：2013-03-26 21:54:46

【问题描述】：

我有 65 个工作簿，每个工作簿中有一个工作表。我需要将所有 65 个工作簿合并为一个工作簿，并将所有相应的工作簿作为新工作簿中的 65 个工作表。我需要将所有 65 个工作簿名称保留为新 SINGLE 工作簿中的工作表名称。

到目前为止，我在网上找到了一个代码来执行此操作，但此代码要求所有将要合并的工作簿都需要打开。有没有办法修改此代码，以便不需要打开所有工作簿？我可以只引用（文件夹）我驱动器上的一个位置吗？

感谢您的帮助！

代码如下：

Option Explicit
Public u_sheets As String

Sub Consolidate()

Dim ws As Worksheet
Dim wb As Workbook, NewBook As Workbook
Dim scount As Integer
Dim NewWS As Worksheet
Dim wsSheet As Worksheet
Dim i As Integer
Dim NextName As String
Dim sl As Integer
Dim newfilepath As String
    newfilepath = ""
Dim first_only As Boolean
    first_only = False

Call init

'are we doing the first sheet only?
If u_sheets = "First Sheet Only" Then first_only = True    

'Setup
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False

'Create new workbook for merged sheets 
 newfilepath = ThisWorkbook.Path & "\Merged" 'excel will auto append the appropriate extension (xlsx)
Set NewBook = Workbooks.Add
NewBook.SaveAs Filename:=newfilepath

i = 1

'Loop through each open workbook
For Each wb In Workbooks

    If wb.Name <> ThisWorkbook.Name And wb.Name <> NewBook.Name And Left(wb.Name, 8) <> "PERSONAL" Then

    Dim x As String

    'Get name of this workbook
    x = JustText(Left(wb.Name, Len(wb.Name) - 4))

        'count sheets in this workbook
        If first_only Then
            scount = 1
        Else
            scount = wb.Sheets.Count
        End If          
        'Loop through each sheet in Workbook
        For Each ws In wb.Worksheets
            'do some naming conventions
            Dim xy As String
            Dim y As String
            y = JustText(ws.Name) 'strip out all characters from name
            If scount > 1 Then                
              xy = x + y                  
            Else                  
              xy = x                  
            End If

            'check the length of the new name and shorten if needed
            sl = Len(xy)

            If sl > 30 Then                
                xy = Right(x, sl - (sl - 30))                
            End If

            'copy worksheet to new workbook
            ws.Copy After:=NewBook.Worksheets(NewBook.Worksheets.Count)

            'rename worksheet
            NewBook.Worksheets(NewBook.Worksheets.Count).Name = xy
            If scount = 1 Then Exit For 'break out of loop if we are only doing one sheet

        Next    
    End If    
Next

'remove all original worksheets
'NewBook.Worksheets("Sheet1").Delete
'NewBook.Worksheets("Sheet2").Delete
'NewBook.Worksheets("Sheet3").Delete    

ErrorExit: 'Cleanup
    Application.DisplayAlerts = True    'turn system alerts back on
    Application.EnableEvents = True     'turn other macros back on
    Application.ScreenUpdating = True   'refreshes the screen

End Sub

Private Function JustText(text_to_clean As String, Optional upper As Boolean = False)
    'removes all characters except for letters and numbers
    'where
    'text_to_clean is the text to clean
    'upper boolean will return UPPER case if true; false if omitted

    'declare and initialize user variables

    Dim method As Integer
        'choices:
        '1=remove everything except what is in the leave_these variable
        '2=leave everything except what is specifically removed from the "leave" section
        method = 1

    Dim leave_these As String   'only used if method=1
        leave_these = "A-Za-z0-9" 'if you want to allow a space "A-Za-z0-9 "

    'declare and initialize system variables
    Dim temp As String
        temp = text_to_clean

    'method
    Select Case method
        Case 1  'remove everything except what is in the leave_these variable
            Dim x As String, y As String, z As String, i As Long
            x = temp
                For i = 1 To Len(x)
                    y = Mid(x, i, 1)
                    If y Like "[" & leave_these & "]" Then z = z & y
                Next i
            temp = z

        Case 2  'leave everything except characters below
            'feel free to comment out the lines for items you do not wish to remove, or add new lines as desired
            temp = Replace(temp, ",", "")   'remove commas
            temp = Replace(temp, " ", "")   'remove spaces
            temp = Replace(temp, "-", "")   'remove dashes
            temp = Replace(temp, ":", "")   'remove colon
            temp = Replace(temp, ";", "")   'remove semi-colon               
    End Select    

    If upper Then JustText = UCase(temp) Else JustText = temp       
End Function

Public Function WorksheetExists(ByVal WorksheetName As String) As Boolean

On Error Resume Next
WorksheetExists = (Sheets(WorksheetName).Name <> "")
On Error GoTo 0    
End Function

Private Sub init()
    'initialize all public variables
    u_sheets = Range("u_sheets")    
End Sub

【参考方案1】：

此代码（之前托管在另一个论坛上）提供了三个选项：

将单个文件夹中所有 Excel 工作簿中的所有工作表整理到单个摘要工作表中 将单个文件夹中所有 Excel 工作簿中的所有工作表整理到单个摘要工作簿中 将单个 Excel 工作簿中的所有工作表整理到单个摘要工作表中

您的请求是 (2)。

代码

Public Sub ConsolidateSheets()
    Dim Wb1 As Workbook
    Dim Wb2 As Workbook
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim ws3 As Worksheet
    Dim rng1 As Range
    Dim rng2 As Range
    Dim rng3 As Range
    Dim rngArea As Range
    Dim lrowSpace As Long
    Dim lSht As Long
    Dim lngCalc As Long
    Dim lngRow As Long
    Dim lngCol As Long
    Dim X()
    Dim bProcessFolder As Boolean
    Dim bNewSheet As Boolean

    Dim StrPrefix
    Dim strFileName As String
    Dim strFolderName As String

    'variant declaration needed for the Shell object to use a default directory
    Dim strDefaultFolder As Variant


 bProcessFolder = (MsgBox("Process a single folder (Yes)," & vbNewLine & "or single file (No)", vbYesNo, "Application Scope: Folder or single File") = vbYes)
    bNewSheet = (MsgBox("Extract all data to a single sheet (Yes)," & vbNewLine & "or a target file sheet for each source sheet (No)", vbYesNo, "Output Format: Single sheet or sheet by sheet collection") = vbYes)
    If Not bProcessFolder Then
        If Not bNewSheet Then
            MsgBox "There isn't much point creating a exact replica of your source file :)"
            Exit Sub
        End If
    End If

    'set default directory here if needed
    strDefaultFolder = "C:\temp"

    'If the user is collating all the sheets to a single target sheet then the row spacing
    'to distinguish between different sheets can be set here
    lrowSpace = 1

    If bProcessFolder Then
        strFolderName = BrowseForFolder(strDefaultFolder)
        'Look for xls, xlsx, xlsm files
        strFileName = Dir(strFolderName & "\*.xls*")
    Else
        strFileName = Application _
                      .GetOpenFilename("Select file to process (*.xls*), *.xls*")
    End If

    Set Wb1 = Workbooks.Add(1)
    Set ws1 = Wb1.Sheets(1)
    If Not bNewSheet Then ws1.Range("A1:B1") = Array("workbook name", "worksheet count")

    'Turn off screenupdating, events, alerts and set calculation to manual
    With Application
        .DisplayAlerts = False
        .EnableEvents = False
        .ScreenUpdating = False
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
    End With

    'set path outside the loop
    StrPrefix = strFolderName & IIf(bProcessFolder, "\", vbNullString)

    Do While Len(strFileName) > 0
        'Provide progress status to user
        Application.StatusBar = Left("Processing " & strFolderName & "\" & strFileName, 255)
        'Open each workbook in the folder of interest
        Set Wb2 = Workbooks.Open(StrPrefix & strFileName)
        If Not bNewSheet Then
            'add summary details to first sheet
            ws1.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) = Wb2.Name
            ws1.Cells(Rows.Count, "A").End(xlUp).Offset(0, 1) = Wb2.Sheets.Count
        End If
        For Each ws2 In Wb2.Sheets
            If bNewSheet Then
                'All data to a single sheet
                'Skip importing target sheet data if the source sheet is blank
                Set rng2 = ws2.Cells.Find("*", ws2.[a1], xlValues, , xlByRows, xlPrevious)

                If Not rng2 Is Nothing Then
                    Set rng1 = ws1.Cells.Find("*", ws1.[a1], xlValues, , xlByRows, xlPrevious)
                    'Find the first blank row on the target sheet
                    If Not rng1 Is Nothing Then
                        Set rng3 = ws2.Range(ws2.UsedRange.Cells(1), ws2.Cells(rng2.Row, "A"))
                        'Ensure that the row area in the target sheet won't be exceeded
                        If rng3.Rows.Count + rng1.Row < Rows.Count Then
                            'Copy the data from the used range of each source sheet to the first blank row
                            'of the target sheet, using the starting column address from the source sheet being copied
                            ws2.UsedRange.Copy ws1.Cells(rng1.Row + 1 + lrowSpace, ws2.UsedRange.Cells(1).Column)
                        Else
                            MsgBox "Summary sheet size exceeded. Process stopped on " & vbNewLine & _
                                   "sheet: " & ws2.Name & vbNewLine & "of" & vbNewLine & "workbook: " & Wb2.Name
                            Wb2.Close False
                            Exit Do
                        End If
                        'colour the first of any spacer rows
                        If lrowSpace <> 0 Then ws1.Rows(rng1.Row + 1).Interior.Color = vbGreen
                    Else
                        'target sheet is empty so copy to first row
                        ws2.UsedRange.Copy ws1.Cells(1, ws2.UsedRange.Cells(1).Column)
                    End If
                End If
            Else
                'new target sheet for each source sheet
                ws2.Copy after:=Wb1.Sheets(Wb1.Sheets.Count)
                'Remove any links in our target sheet
                With Wb1.Sheets(Wb1.Sheets.Count).Cells
                    .Copy
                    .PasteSpecial xlPasteValues
                End With
                On Error Resume Next
                Wb1.Sheets(Wb1.Sheets.Count).Name = ws2.Name
                'sheet name already exists in target workbook
                If Err.Number <> 0 Then
                    'Add a number to the sheet name till a unique name is derived
                    Do
                        lSht = lSht + 1
                        Set ws3 = Wb1.Sheets(ws2.Name & " " & lSht)
                    Loop While Not ws3 Is Nothing
                    lSht = 0
                End If
                On Error GoTo 0
            End If
        Next ws2
        'Close the opened workbook
        Wb2.Close False
        'Check whether to force a DO loop exit if processing a single file
        If bProcessFolder = False Then Exit Do
        strFileName = Dir
    Loop

    'Remove any links if the user has used a target sheet
    If bNewSheet Then
        With ws1.UsedRange
            .Copy
            .Cells(1).PasteSpecial xlPasteValues
            .Cells(1).Activate
        End With
    Else
        'Format the summary sheet if the user has created separate target sheets
        ws1.Activate
        ws1.Range("A1:B1").Font.Bold = True
        ws1.Columns.AutoFit
    End If

    With Application
        .CutCopyMode = False
        .DisplayAlerts = True
        .EnableEvents = True
        .ScreenUpdating = True
        .Calculation = lngCalc
        .StatusBar = vbNullString
    End With
End Sub


Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'From Ken Puls as used in his vbaexpress.com article
'http://www.vbaexpress.com/kb/getarticle.php?kb_id=284

    Dim ShellApp As Object
    'Create a file browser window at the default folder
    Set ShellApp = CreateObject("Shell.Application"). _
                   BrowseForFolder(0, "Please choose a folder", 0, OpenAt)

    'Set the folder to that selected.  (On error in case cancelled)
    On Error Resume Next
    BrowseForFolder = ShellApp.self.Path
    On Error GoTo 0

    'Destroy the Shell Application
    Set ShellApp = Nothing

    'Check for invalid or non-entries and send to the Invalid error
    'handler if found
    'Valid selections can begin L: (where L is a letter) or
    '\\ (as in \\servername\sharename.  All others are invalid
    Select Case Mid(BrowseForFolder, 2, 1)
    Case Is = ":"
        If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
    Case Is = "\"
        If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
    Case Else
        GoTo Invalid
    End Select

    Exit Function

Invalid:
    'If it was determined that the selection was invalid, set to False
    BrowseForFolder = False
End Function 

【讨论】：

您好！我试图运行您的代码以将多个 Excel 文件合并到一个单独的工作表中。我选择了是 > 否；出现了一个新文件，其中包含 workbook 和 worksheet count。什么都没有发生，还是我必须等待左下角显示Processing C:\path\to\multiple\excel\files 的日志？

【参考方案2】：

是的，您可以，您可以使用 Dir 命令查看该目录中存在哪些 .xls 或 .xlsx 或 xlsm（适合您的情况），然后使用循环使用 Workbooks.Open 打开一个，将其中的工作表添加到原始工作簿中，将其关闭，然后循环到 de Dir 列表中的下一个工作簿。

以这种方式使用 Dir 为例：

    Dim strPath As String
    Dim strFile As String

    strPath = "C:\yourfolder\"

    strFile = Dir(strPath & "*.xlsx")

    Do Until strFile = ""

        ' ...YOURCODE HERE

    Loop

这将代替For each wb in Workbooks，您可以申请Set wb = Workbooks.Open strPath & strFile，并且仍然使用您原始代码的其余部分来复制工作表。

【参考方案3】：

请使用插件 RDBMerge。

RDBMerge 是一种用户友好的方式，可以将多个 Excel 工作簿、csv 和 xml 文件中的数据合并到摘要工作簿中

http://www.rondebruin.nl/merge.htm

Merge Multiple Workbooks From Different Folders Into One