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.
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?
Thanks for your help!
Here is the 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 & "\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
