Combine the Workbooks in a Folder
The following macro creates a new worksheet, and copies the data from Sheet1 of each workbook in the specified folder to this new worksheet...
'Force the explicit
declaration of variables
Option Explicit
Sub
CombineWorkbooks()
'Declare the variables
Dim strPath As String
Dim strFile As String
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 Cnt 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 & "\"
'Get the first Excel file
from the folder
strFile = Dir(strPath &
"*.xls", vbNormal)
'If no Excel files are found
in the folder, exit the sub
If strFile = "" Then
MsgBox
"No Excel files were found...", vbExclamation
Exit Sub
End If
'Change the settings for
Calculation, EnableEvents, and ScreenUpdating
With Application
CalcMode
= .Calculation
.Calculation
= xlCalculationManual
.EnableEvents
= False
.ScreenUpdating
= False
End With
'Create a new workbook with
one worksheet
Set wksDest =
Workbooks.Add(xlWBATWorksheet).Worksheets(1)
'Specify the row in which to
start copying the data
NextRow = 1
'Loop through each Excel file
in the folder...
Do While
Len(strFile) > 0
'...except this one, in case
it's included in the folder
If strFile
<> ThisWorkbook.Name Then
'Increment by 1 the count of
workbooks opened
Cnt
= Cnt + 1
'Open the current file
Set wkbSource =
Workbooks.Open(strPath & strFile)
'Set the source worksheet
Set wksSource =
wkbSource.Worksheets("Sheet1")
'Find the last used row
LastRow
= wksSource.Cells.Find( _
What:="*",
_
After:=wksSource.Range("A1"),
_
LookIn:=xlFormulas,
_
LookAt:=xlPart,
_
SearchOrder:=xlByRows,
_
SearchDirection:=xlPrevious,
_
MatchCase:=False).Row
'Set the source range
If Cnt = 1 Then
Set SourceRange
= wksSource.Range("A1:D" & LastRow)
Else
Set SourceRange
= wksSource.Range("A2:D" & LastRow)
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, not enough rows in the worksheet...", vbExclamation
wkbSource.Close
savechanges:=False
GoTo ExitSub
End If
'Copy the data from the
source range to the destination sheet
SourceRange.Copy
Destination:=wksDest.Cells(NextRow, "A")
'Determine the next available
row in the destination worksheet
NextRow
= NextRow + SourceRowCount
'Close the current file,
without saving it
wkbSource.Close
savechanges:=False
End If
'Get the next Excel file from
the folder
strFile
= Dir
Loop
'Change the width of the
columns to achieve the best fit
wksDest.Columns.AutoFit
ExitSub:
'Restore the settings for
Calculation, EnableEvents, and ScreenUpdating
With Application
.Calculation
= CalcMode
.EnableEvents
= True
.ScreenUpdating
= True
End With
End Sub
Tip 1: A worksheet can be referenced by index number instead of a sheet name (ie. 1 = first sheet, 2 = second sheet, etc.). 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)
Tip 2: To copy only values and exclude the formatting, replace...
SourceRange.Copy Destination:=wksDest.Cells(NextRow, "A")
with
With
SourceRange
wksDest.Cells(NextRow,
"A").Resize(.Rows.Count, .Columns.Count).Value = .Value
End With
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