title: Merging Several Workbooks Into One Workbook with All the Workbooks as Sheets
body: <p>I have 65 workbooks with one worksheet in each workbook. I need to combine all 65 workbooks into one workbook, with all the respective workbooks as 65 worksheets in the new workbook. I need to keep all the 65 workbook names as the worksheet names in the new SINGLE workbook. </p>
  
  <p>I have a code so far to do this that I found online for this, but this code requires that all the workbooks that will be merged, need to be OPEN. Is there any way to modify this code so that all the workbooks don't need to be open? Can I just reference(folder) a location on my drive?</p>
  
  <p>Thanks for your help!</p>
  
  <p>Here is the code:</p>
  
  <pre><code>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 &amp; "\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 &lt;&gt; ThisWorkbook.Name And wb.Name &lt;&gt; NewBook.Name And Left(wb.Name, 8) &lt;&gt; "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 &gt; 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 &gt; 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 "[" &amp; leave_these &amp; "]" Then z = z &amp; 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 &lt;&gt; "")
  On Error GoTo 0    
  End Function
  
  Private Sub init()
      'initialize all public variables
      u_sheets = Range("u_sheets")    
  End Sub
  </code></pre>