You can do the following...
1) open the files that you need merged
2) Create a module and name it ConsolidateWB (or whatever you like) and paste in there
Code:
Option Explicit
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
Dim lReply As Long
' make StatusBar visible
Application.DisplayStatusBar = True
'First Message
Application.statusbar = String(5, ChrW(46)) & " Starting"
Application.Wait Now + TimeValue("00:00:02")
'are we doing the first sheet only?
lReply = MsgBox("To merge All Sheets select 'Yes'" & " " & " To merge First Sheet Only select 'No'", vbYesNoCancel, "Choose sheets to merge")
If lReply = vbCancel Then Exit Sub
If lReply = vbNo Then first_only = True
'Setup
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
'Second Message
Application.statusbar = String(10, ChrW(46)) & " Working"
Application.Wait Now + TimeValue("00:00:02")
'Create new workbook for merged sheets
newfilepath = Environ("USERPROFILE") & "\Desktop\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
'Third Message
Application.statusbar = String(15, ChrW(46)) & " Finalizing"
Application.Wait Now + TimeValue("00:00:02")
'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
'Last Message
Application.statusbar = String(15, ChrW(46)) & " Done!"
Application.Wait Now + TimeValue("00:00:02")
'-- Replace this line with your own code to do something
'Relinquish the StatusBar
Application.statusbar = False
ActiveWorkbook.Save
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
3) Run Macro "Consolidate"
Doing the above will merge all the currently open workbooks into a new file that will be placed in Desktop with the name Merged.xlsx
You will also be prompted to reply if you want to merge the 1st sheet only or all.
I have found this on the web, I take no credit for compiling any of this.
Sadly I do not have the reference to the original code source.
The only changes that I have done to the code structure are immaterial and restricted to:
- adding a message about the progress in the statusbar but slows the code a bit so you can remove it if you want
- originally the file was created on Desktop was xls and changed it to xlsx
- and finally I changed the way Desktop folder is located (that under Win7 is username related) so that it could work for multiple users
I hope that this will help you.
You can afterwards delete any of the sheets you don't want to keep.
Mr.B.
Reply With Quote
Bookmarks