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

Question

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

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

感谢您的帮助！

下面是代码：

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 

Answer 1

是的，你可以，你可以使用Dir命令，以便了解哪些的.xls或.xlsx或XLSM（无论适合您的情况）存在于该目录，然后使用在其中使用Workbooks.Open打开一个循环，将其中的工作表添加到原始工作簿中，关闭它，然后循环到de 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，仍然使用原来的代码的其余部分的复制表。

Answer 2

请使用插件RDBMerge。

RDBMerge是从多个Excel工作簿，CSV和XML文件的数据合并到一个汇总工作簿

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

Merge Multiple Workbooks From Different Folders Into One

Answer 3

此代码（以前在其他论坛主办）提供了一个用户友好的方式三种选择：

1. 将所有工作表中的所有工作表从单个文件夹中的所有工作表整合到一个摘要中w orksheet
2. 分页从单个文件夹中的所有的Excel工作簿的所有片材成一个单一的概要的工作簿
3. 分页从单个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