Combine the Workbooks in a Folder
The following procedure creates a new workbook containing one worksheet in which to combine the data. Then it copies the data from "Sheet1" of each workbook in the specified folder to the worksheet in the newly created workbook.
Note that it's assumed that the source data contains column headers in the first row. Also, the workbook containing this code can be located in the same folder as the other workbooks.
'Force
the explicit
declaration of variables
Option Explicit
Sub
CombineWorkbooks()
'Declare the variables
Dim arrFiles() As String
Dim strPath As String
Dim strFile As String
Dim wkbDest As Workbook
Dim wksDest As Worksheet
Dim wkbSource As Workbook
Dim wksSource As Worksheet
Dim SourceRange As Range
Dim
SourceRowCount As
Long
Dim NextRow As Long
Dim LastRow As Long
Dim LastCol As Long
Dim FileCnt As Long
Dim Cnt As Long
Dim i As Long
Dim CalcMode As Long
'Specify the path to the
folder containing the files
strPath = "C:\Users\Domenic\Documents\"
'Make sure that the path ends
in a backslash
If
Right(strPath, 1) <> "\" Then strPath =
strPath & "\"
'Check if the path exists
If
Len(Dir(strPath, vbDirectory)) = 0 Then
MsgBox
"The path to your folder does not exist. Please
check" & vbCrLf & _
"the
path, and try again!", vbExclamation
Exit Sub
End If
'Get the first Excel file
from the folder
strFile = Dir(strPath &
"*.xls", vbNormal)
'Fill the array with a list
of Excel files in the folder...
FileCnt = 0
Do While
Len(strFile) > 0
'...except this workbook, in
case it's in the same folder
If strFile
<> ThisWorkbook.Name Then
FileCnt
= FileCnt + 1
ReDim Preserve
arrFiles(1 To
FileCnt)
arrFiles(FileCnt)
= strFile
End If
'Get the next Excel file from
the folder
strFile
= Dir
Loop
'If no Excel files were
found, exit the sub
If FileCnt = 0 Then
MsgBox
"No Excel files were found...", vbExclamation
Exit Sub
End If
'Change the settings for
Calculation, DisplayAlerts, EnableEvents,
'and ScreenUpdating
With Application
CalcMode
= .Calculation
.Calculation
= xlCalculationManual
.DisplayAlerts
= False
.EnableEvents
= False
.ScreenUpdating
= False
End With
'Create a new workbook with
one worksheet
Set wkbDest =
Workbooks.Add(xlWBATWorksheet)
'Set the destination worksheet
Set wksDest =
wkbDest.Worksheets(1)
'Specify the row in which to
start copying the data
NextRow = 1
'Loop through each Excel file
in the array...
Cnt = 0
For i = LBound(arrFiles)
To UBound(arrFiles)
'Open the current file
Set wkbSource =
Workbooks.Open(strPath & arrFiles(i))
'Set the source worksheet
On Error Resume Next
Set wksSource =
wkbSource.Worksheets("Sheet1")
On Error GoTo 0
'Check if the worksheet exists
If Not wksSource Is Nothing Then
With wksSource
'Find the last used row in
Column A
LastRow
= .Cells(.Rows.Count, "A").End(xlUp).Row
'Find the last used column in
Row 1
LastCol
= .Cells(1, .Columns.Count).End(xlToLeft).Column
'Check if the worksheet
contains data beyond column headers
If LastRow
> 1 Then
'Increase the count by one
Cnt
= Cnt + 1
'Set the source range...
If Cnt = 1 Then
'...including the column
headers
Set SourceRange
= .Range("A1", .Cells(LastRow, LastCol))
Else
'...excluding the column
headers
Set SourceRange
= .Range("A2", .Cells(LastRow, LastCol))
End If
'Count the number of rows in
the source range
SourceRowCount
= SourceRange.Rows.Count
'If there aren't enough rows
in the destination sheet,
'exit the sub
If NextRow +
SourceRowCount - 1 > wksDest.Rows.Count Then
MsgBox
"Sorry, there are not enough rows available " & _
"in the destination worksheet!",
vbExclamation
wkbSource.Close
savechanges:=False
GoTo ExitSub
End If
'Copy the data from the
source range to the destination sheet
SourceRange.Copy
With
wksDest.Cells(NextRow, "A")
.PasteSpecial
Paste:=xlPasteValues
.PasteSpecial
Paste:=xlPasteFormats
End With
'Determine the next available
row
NextRow
= NextRow
+ SourceRowCount
End If
End With
'Set the object variable for
the source worksheet to Nothing
Set wksSource = Nothing
End If
'Close the current file,
without saving it
wkbSource.Close
savechanges:=False
Next i
'Check if any data has been
copied to the destination worksheet
If Cnt >
0 Then
'Select the first cell and
change the width of the columns to
'achieve
the best fit
With wksDest
.Cells(1).Select
.Columns.AutoFit
End With
Else
'Display message box advising
user that no data was available to be copied
MsgBox
"No data was available to be copied...", vbInformation
'Close the destination
workbook, without saving it
wkbDest.Close
savechanges:=False
End If
ExitSub:
'Restore the settings for
Calculation, DisplayAlerts, EnableEvents,
'and ScreenUpdating
With Application
.Calculation
= CalcMode
.DisplayAlerts
= True
.EnableEvents
= True
.ScreenUpdating
= True
End With
End Sub
Tip
A worksheet can be referenced by index number instead of a
sheet name. Therefore, to refer to the first sheet of each workbook
instead of "Sheet1", replace...
Set
wksSource =
wkbSource.Worksheets("Sheet1")
with
Set
wksSource =
wkbSource.Worksheets(1)
Where to Put the Code
- Open the workbook in which to store the code.
- Open the Visual Basic Editor (Alt+F11).
- Insert a standard module (Insert > Module).
- Copy/paste the above code into the module.
- Return to Microsoft Excel (Alt+Q).
- Save the workbook.
How to Use the Macro
- Display the Macro dialog box (Alt+F8).
- Click/select the macro called "CombineWorkbooks".
- Click/select "Run".
Sample Workbook: Download