Merge Workbooks
Excel VBA Code to Merge Workbooks
This VBA code will browse through a folder named "merged" on your desktop, and merge all of the workbooks together into one super workbook (one sheet) called "merged.xls". So for example, if someone sent you 10 attachments in an Outlook email, you could click "Save Attachments" and create a folder called "merged", then run this macro to glue them all together. You could go even further and convert this to Outlook code, and automate the entire process. Currently the code works for Windows XP only, if you want to use this with Vista, you need to adjust the path to the Desktop folder.
Update 12/4/2008: The function Environ("userprofile") returns the path to the current user's profile. The desktop path for that user follows accordingly. So the code now works independent of operating system (I still assume most Windows users are using either XP or Vista).
(ByVal lpBuffer As String, nSize As Long) As Long
Public Function UserName() As String
Dim lpBuff As String * 1024
GetUserName lpBuff, Len(lpBuff)
UserName = Left$(lpBuff, (Instr(1, lpBuff, vbNullChar)) -1)
End Function
Sub MergeWorkbooks()
Dim NewWB As Excel.Workbook
Dim FName As String
Dim myLastCell As String, myLastRow As String, myLastColumn As Long
Dim myRange As String
Dim directoryfiles()
Dim count As Integer
Dim filen As String
Dim UserN As String, AddRange As Excel.Range
Dim i As Long
Dim DesktopPath As String
Application.ScreenUpdating = False
UserN = UserName
DesktopPath = Environ("userprofile") & "\Desktop\"
If Dir(DesktopPath & "merged.xls") <> "" Then
MsgBox ("File already exists, clear it out before running this macro"), _
vbCritical
Exit Sub
End If
If Dir(DesktopPath & "merged\*.xls") = "" Then
MsgBox ("No XLS files are in the MERGED directory." & vbCrLf & _
"Put some workbooks there first."), vbCritical
Exit Sub
End If
filen = Dir(DesktopPath & "merged\")
' build a list of workbooks
Do
If filen <> "" Then
ReDim Preserve directoryfiles(count)
directoryfiles(count) = filen
count = count + 1
End If
filen = dir
Loop While filen <> ""
Set NewWB = Workbooks.Add
Activeworkbook.SaveAs DesktopPath & "merged.xls", FileFormat:=xlNormal
Set AddRange = Workbooks("merged.xls").Worksheets(1).Range("A65536")
For i = 0 to UBound(directoryfiles())
Workbooks.Open (DesktopPath & "merged\" & _
directoryfiles(i)
' delete extra rows to clean up file
Dim R As Long
Dim rng As Excel.Range
Set rng = ActiveSheet.UsedRange.Rows
For R = rng.Rows.count To 1 Step -1
If WorksheetFunction.CountA(rng.Rows(R).EntireRow) = 0 Then
rng.Rows(R).EntireRow.Delete
End If
Next R
' find used range
myLastRow = Cells.Find("*", [A1],,, xlByRows, xlPrevious).Row
myLastColumn = Cells.Find("*", [A1],,, xlByColumns, xlPrevious).Column
myLastCell = Cells(myLastRow, myLastColumn).Address
myRange = "A1:" & myLastCell
Range(myRange).Copy Destination:=AddRange.End(xlUp).Offset(2,0)
Workbooks(directoryfiles(i)).Close savechanges:=False
Next i
Workbooks("merged.xls").Close savechanges:=True
Set NewWB = Nothing
Set AddRange = Nothing
MsgBox ("Merge complete!" & vbCrLf & vbCrLf & UBound(directoryfiles()) + 1 & _
" workbooks were merged."), vbInformation
If MsgBox("Would you like to delete the separate workbooks?") = vbYes Then
For i = 0 To UBound(directoryfiles())
Kill (DesktopPath & "merged\" & _
directoryfiles(i))
Next i
MsgBox ("Done!"), vbInformation
End If
Application.ScreenUpdating = True
End Sub
Merge Workbooks, keep each worksheet separate
You may want to merge a series of workbooks, preserving each worksheet instead of merging them into one super worksheet. For example, you might have 10 workbooks, with five worksheets each. You want to put all fifty worksheets together into one workbook. If so, this code will work for you.
Note that the original workbooks will not be altered or deleted.
The following code will prompt you for the workbooks you want to merge. It creates a new workbook and then copies the worksheets from each of those workbooks into the new one. Let's see how it works.
Dim newWorkbook As Excel.Workbook
Dim filesToMerge As Variant
Dim i As Long
' choose workbooks to merge
filesToMerge = GetFilenames("Choose workbooks to merge", True)
Application.ScreenUpdating = False
' create new workbook
Set newWorkbook = Excel.Workbooks.Add
' for each worksheet in each workbook, copy to new workbook
For i = LBound(filesToMerge) To UBound(filesToMerge)
Call CopyWorksheets(CStr(filesToMerge(i)), newWorkbook)
Next i
Application.ScreenUpdating = True
End Sub
Using the GetFilenames function, the procedure asks you to select the workbooks you want to merge. I didn't check to see if more than one file was selected. The filenames are passed to another function (CopyWorksheets) which adds the worksheets to the newly created workbook.
Get Filenames
This function returns the selected filenames to the calling procedure. If you use Excel 2007 or newer, change the file extension to .xlsx.
' returns selected filenames
On Error Resume Next
GetFilenames = Application.GetOpenFilename("Excel Files (*.xls), *.xls", , caption, , multi)
End Function
Copy Worksheets Function
This function takes two parameters: the filename (String) of the workbook you want to merge, and the workbook where the merged worksheets should go. In the main procedure, we pass each filename in turn, and pass in the same destination workbook each time.
The Worksheets.Copy method copies all the worksheets in the given workbook all at once, instead of looping through the Worksheets collection and using the Worksheet.Copy method to copy each one.
Dim sourceWorkbook As Excel.Workbook
Dim sourceWkshts As Excel.Sheets
' open source workbook
Set sourceWorkbook = Excel.Workbooks.Open(sourceWkbk)
' grab worksheets
Set sourceWkshts = sourceWorkbook.Sheets
' copy worksheets to destination workbook
sourceWkshts.Copy after:=destinationWkbk.Worksheets(1)
sourceWorkbook.Close False
End Sub
