Code Examples that use DIR
There are four basic examples:
1) Merge a range from all workbooks in a folder (below each
other)
2) Merge a range from every workbook you select (below each
other)
3) Merge a range from all workbooks in a folder (next to
each other)
4) Merge a range from all workbooks in a folder with
AutoFilter
The code will create a new workbook for you with the data from all workbooks
with in column A or in row 1 the file name of the data i
n
that row or column.
It is up to you if you save the workbook.
Information and Tips
The examples below are only working for one folder (no option for
subfolders).
Note: the workbook with the code must be outside the merge
folder
Tip 1: Useful Workbooks.Open arguments
Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum), _
Password:="ron", WriteResPassword:="ron", UpdateLinks:=0)
If your workbooks are protected you can us this in the Workbooks.Open
arguments
Password:="ron” and WriteResPassword:="ron"
If you have links in your workbook this (
UpdateLinks:=0)
will avoid the message
do you want to update the links or not "
0 Doesn't update any references"
Use
3 instead of
0 if you want to update
the links.
See the VBA help for more information about the Workbooks.Open arguments
Tip 2: merge from all Files with a name that start with for
example
week
Use this then
FilesInPath = Dir(MyPath & "week*.xl*")
Tip 3 : Copy values and formats
the macro examples below will copy only the values, if you want to copy
the formats also replace this :
With SourceRange
Set destrange = destrange. _
Resize(.Rows.Count, .Columns.Count)
End With
destrange.Value = SourceRange.Value
WithSourceRange.Copy
With destrange
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
Before you restore ScreenUpdating, Calculation and EnableEvents also add
this line
Application.Goto BaseWks.Cells(1)
Merge a range from all workbooks in a folder (below each
other)
There are a few things you must change before you can run the code
Fill in the path to the folder
MyPath = "C:\Users\Ron\test"
I use the first worksheet of each workbook in my example (index 1)
Change the worksheet index or fill in a sheet name:
mybook.Worksheets("YourSheetName")
And change the range
A1:C1 to your range
With mybook.Worksheets(1)
Set SourceRange = .Range("A1:C1")
End With
If you want to copy all cells from the worksheet or from
A2 till the last cell
on the worksheet.
Then replace the code above with this
With mybook.Worksheets(1)
FirstCell = "A2"
Set SourceRange = .Range(FirstCell & ":" & RDB_Last(3, .Cells))
'Test if the row of the last cell >= then the row of the FirstCell
If RDB_Last(1, .Cells) < .Range(FirstCell).Row Then
Set SourceRange = Nothing
End If
End With
Add also this dim line at the top of the macro
Dim FirstCell As String
Note: the code above use the function
RDB_Last,
copy this function also in your code module
if you use it. You find the function in the last section of this page.
Fill in the first cell here and the code will find the last cell on the
worksheet for you.
FirstCell = "A2"
Sub Basic_Example_1()
Dim MyPath As String, FilesInPath As String
Dim MyFiles() As String
Dim SourceRcount As Long, Fnum As Long
Dim mybook As Workbook, BaseWks As Worksheet
Dim sourceRange As Range, destrange As Range
Dim rnum As Long, CalcMode As Long
'Fill in the path\folder where the files are
MyPath = "C:\Users\Ron\test"
'Add a slash at the end if the user forget it
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If
'If there are no Excel files in the folder exit the sub
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If
'Fill the array(myFiles)with the list of Excel files in the folder
Fnum = 0
Do While FilesInPath <> ""
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FilesInPath
FilesInPath = Dir()
Loop
'Change ScreenUpdating, Calculation and EnableEvents
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
'Add a new workbook with one sheet
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
rnum = 1
'Loop through all files in the array(myFiles)
If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
On Error GoTo 0
If Not mybook Is Nothing Then
On Error Resume Next
With mybook.Worksheets(1)
Set sourceRange = .Range("A1:C1")
End With
If Err.Number > 0 Then
Err.Clear
Set sourceRange = Nothing
Else
'if SourceRange use all columns then skip this file
If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
Set sourceRange = Nothing
End If
End If
On Error GoTo 0
If Not sourceRange Is Nothing Then
SourceRcount = sourceRange.Rows.Count
If rnum + SourceRcount >= BaseWks.Rows.Count Then
MsgBox "Sorry there are not enough rows in the sheet"
BaseWks.Columns.AutoFit
mybook.Close savechanges:=False
GoTo ExitTheSub
Else
'Copy the file name in column A
With sourceRange
BaseWks.cells(rnum, "A"). _
Resize(.Rows.Count).Value = MyFiles(Fnum)
End With
'Set the destrange
Set destrange = BaseWks.Range("B" & rnum)
'we copy the values from the sourceRange to the destrange
With sourceRange
Set destrange = destrange. _
Resize(.Rows.Count, .Columns.Count)
End With
destrange.Value = sourceRange.Value
rnum = rnum + SourceRcount
End If
End If
mybook.Close savechanges:=False
End If
Next Fnum
BaseWks.Columns.AutoFit
End If
ExitTheSub:
'Restore ScreenUpdating, Calculation and EnableEvents
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub
Merge a range from every workbook you select (below each
other)
This code example will do the same as the example above only when you run
the code
you
are able to select the files you want to merge.
Fill in the path to the folder
ChDirNet "C:\Users\Ron\test"
and change the sheet and range to yours (see first example)
It is also possible to set the start folder with
ChDrive
and
ChDir but I choose to use the
SetCurrentDirectoryA function in this example because
it also is working with network folders.
Note: Copy all code below in a normal module
#If VBA7 Then
Declare PtrSafe Function SetCurrentDirectoryA Lib _
"kernel32" (ByVal lpPathName As String) As Long
#Else
Declare Function SetCurrentDirectoryA Lib _
"kernel32" (ByVal lpPathName As String) As Long
#End If
Sub ChDirNet(szPath As String)
SetCurrentDirectoryA szPath
End Sub
Sub Basic_Example_2()
Dim MyPath As String
Dim SourceRcount As Long, Fnum As Long
Dim mybook As Workbook, BaseWks As Worksheet
Dim sourceRange As Range, destrange As Range
Dim rnum As Long, CalcMode As Long
Dim SaveDriveDir As String
Dim FName As Variant
'Change ScreenUpdating, Calculation and EnableEvents
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
SaveDriveDir = CurDir
ChDirNet "C:\Users\Ron\test"
FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xl*), *.xl*", _
MultiSelect:=True)
If IsArray(FName) Then
'Add a new workbook with one sheet
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
rnum = 1
'Loop through all files in the array(myFiles)
For Fnum = LBound(FName) To UBound(FName)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(FName(Fnum))
On Error GoTo 0
If Not mybook Is Nothing Then
On Error Resume Next
With mybook.Worksheets(1)
Set sourceRange = .Range("A1:C1")
End With
If Err.Number > 0 Then
Err.Clear
Set sourceRange = Nothing
Else
'if SourceRange use all columns then skip this file
If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
Set sourceRange = Nothing
End If
End If
On Error GoTo 0
If Not sourceRange Is Nothing Then
SourceRcount = sourceRange.Rows.Count
If rnum + SourceRcount >= BaseWks.Rows.Count Then
MsgBox "Sorry there are not enough rows in the sheet"
BaseWks.Columns.AutoFit
mybook.Close savechanges:=False
GoTo ExitTheSub
Else
'Copy the file name in column A
With sourceRange
BaseWks.Cells(rnum, "A"). _
Resize(.Rows.Count).Value = FName(Fnum)
End With
'Set the destrange
Set destrange = BaseWks.Range("B" & rnum)
'we copy the values from the sourceRange to the destrange
With sourceRange
Set destrange = destrange. _
Resize(.Rows.Count, .Columns.Count)
End With
destrange.Value = sourceRange.Value
rnum = rnum + SourceRcount
End If
End If
mybook.Close savechanges:=False
End If
Next Fnum
BaseWks.Columns.AutoFit
End If
ExitTheSub:
'Restore ScreenUpdating, Calculation and EnableEvents
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
ChDirNet SaveDriveDir
End Sub
Merge a range from all workbooks in a folder (next to
each other)
This example will past the data next to each other. In column A you see the
data from the first
workbook and in Column B the data from the next and in.....
There are a few things you must change before you can run the code
Fill in the path to the folder
MyPath = "C:\Users\Ron\test"
I use the first sheet of each workbook in my example (index 1)
Change the sheet index or fill in a sheet name:
mybook.Worksheets("YourSheetName")
And change the range
A1:A10 to your range.
Set sourceRange = mybook.Worksheets(1).Range("A1:A10")
Sub Basic_Example_3()
Dim MyPath As String, FilesInPath As String
Dim MyFiles() As String
Dim SourceCcount As Long, Fnum As Long
Dim mybook As Workbook, BaseWks As Worksheet
Dim sourceRange As Range, destrange As Range
Dim Cnum As Long, CalcMode As Long
'Fill in the path\folder where the files are
MyPath = "C:\Users\Ron\test"
'Add a slash at the end if the user forget it
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If
'If there are no Excel files in the folder exit the sub
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If
'Fill the array(myFiles)with the list of Excel files in the folder
Fnum = 0
Do While FilesInPath <> ""
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FilesInPath
FilesInPath = Dir()
Loop
'Change ScreenUpdating, Calculation and EnableEvents
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
'Add a new workbook with one sheet
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
Cnum = 1
'Loop through all files in the array(myFiles)
If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
On Error GoTo 0
If Not mybook Is Nothing Then
On Error Resume Next
Set sourceRange = mybook.Worksheets(1).Range("A1:A10")
If Err.Number > 0 Then
Err.Clear
Set sourceRange = Nothing
Else
'if SourceRange use all rows then skip this file
If sourceRange.Rows.Count >= BaseWks.Rows.Count Then
Set sourceRange = Nothing
End If
End If
On Error GoTo 0
If Not sourceRange Is Nothing Then
SourceCcount = sourceRange.Columns.Count
If Cnum + SourceCcount >= BaseWks.Columns.Count Then
MsgBox "Sorry there are not enough columns in the sheet"
BaseWks.Columns.AutoFit
mybook.Close savechanges:=False
GoTo ExitTheSub
Else
'Copy the file name in the first row
With sourceRange
BaseWks.cells(1, Cnum). _
Resize(, .Columns.Count).Value = MyFiles(Fnum)
End With
'Set the destrange
Set destrange = BaseWks.cells(2, Cnum)
'we copy the values from the sourceRange to the destrange
With sourceRange
Set destrange = destrange. _
Resize(.Rows.Count, .Columns.Count)
End With
destrange.Value = sourceRange.Value
Cnum = Cnum + SourceCcount
End If
End If
mybook.Close savechanges:=False
End If
Next Fnum
BaseWks.Columns.AutoFit
End If
ExitTheSub:
'Restore ScreenUpdating, Calculation and EnableEvents
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub
Merge a range from all workbooks in a folder with
AutoFilter
This example will filter a range on a worksheet in every workbook in the
folder and copy
the filter results to a new workbook.
There are five code lines that you must change before you run the code(see
macro)
Note: the code use the function
RDB_Last, copy this function also in your code module.
You find the function in the last section of this page.
Sub Basic_Example_4()
Dim MyPath As String, FilesInPath As String
Dim MyFiles() As String
Dim SourceRcount As Long, FNum As Long
Dim mybook As Workbook, BaseWks As Worksheet
Dim sourceRange As Range, destrange As Range
Dim rnum As Long, CalcMode As Long
Dim rng As Range, SearchValue As String
Dim FilterField As Integer, RangeAddress As String
Dim ShName As Variant, RwCount As Long
'**********************************************************
'***Change this five code lines before you run the macro***
'**********************************************************
'Fill in the path\folder where the files are
MyPath = "C:\Users\Ron\test"
'Fill in the sheet name where the data is in each workbook
'Use ShName = "Sheet1" if you want to use a sheet name instead if the index
'We use the first sheet in every workbook in this example(I use the index)
ShName = 1
'Fill in the filter range: A1 is the header of the first column and G is
'the last column in the range and it will filter on all rows on the sheet
'You can also use a fixed range like A1:G2500 if you want
RangeAddress = Range("A1:G" & Rows.Count).Address
'Field that you want to filter in the range ( 1 = column A in this
'example because the filter range start in column A
FilterField = 1
'Fill in the filter value ("<>ron" if you want the opposite)
'Or use wildcards like "*ron" for cells that start with ron or use
'"*ron*" if you look for cells where ron is a part of the cell value
SearchValue = "ron"
'**********************************************************
'**********************************************************
'Add a slash after MyPath if the user forget it
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If
'If there are no Excel files in the folder exit the sub
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If
'Fill the array(myFiles)with the list of Excel files in the folder
FNum = 0
Do While FilesInPath <> ""
FNum = FNum + 1
ReDim Preserve MyFiles(1 To FNum)
MyFiles(FNum) = FilesInPath
FilesInPath = Dir()
Loop
'Change ScreenUpdating, Calculation and EnableEvents
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
'Add a new workbook with one sheet
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
rnum = 1
'Loop through all files in the array(myFiles)
If FNum > 0 Then
For FNum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))
On Error GoTo 0
If Not mybook Is Nothing Then
On Error Resume Next
'set filter range
With mybook.Worksheets(ShName)
Set sourceRange = .Range(RangeAddress)
End With
If Err.Number > 0 Then
Err.Clear
Set sourceRange = Nothing
End If
On Error GoTo 0
If Not sourceRange Is Nothing Then
'Find the last row in BaseWks
rnum = RDB_Last(1, BaseWks.Cells) + 1
With sourceRange.Parent
Set rng = Nothing
'Firstly, remove the AutoFilter
.AutoFilterMode = False
'Filter the range on the FilterField column
sourceRange.AutoFilter Field:=FilterField, _
Criteria1:=SearchValue
With .AutoFilter.Range
'Check if there are results after you use AutoFilter
RwCount = .Columns(1).Cells. _
SpecialCells(xlCellTypeVisible).Cells.Count - 1
If RwCount = 0 Then
'There is no data, only the header
Else
' Set a range without the Header row
Set rng = .Resize(.Rows.Count - 1, .Columns.Count). _
Offset(1, 0).SpecialCells(xlCellTypeVisible)
'Copy the range and the file name in column A
If rnum + RwCount < BaseWks.Rows.Count Then
BaseWks.Cells(rnum, "A").Resize(RwCount).Value _
= mybook.Name
rng.Copy BaseWks.Cells(rnum, "B")
End If
End If
End With
'Remove the AutoFilter
.AutoFilterMode = False
End With
End If
'Close the workbook without saving
mybook.Close savechanges:=False
End If
'Open the next workbook
Next FNum
'Set the column width in the new workbook
BaseWks.Columns.AutoFit
MsgBox "Look at the merge results in the new workbook after you click on OK"
End If
'Restore ScreenUpdating, Calculation and EnableEvents
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub
RDB_Last function to find the last cell or row
Function RDB_Last(choice As Integer, rng As Range)
'Ron de Bruin, 5 May 2008
' 1 = last row
' 2 = last column
' 3 = last cell
Dim lrw As Long
Dim lcol As Integer
Select Case choice
Case 1:
On Error Resume Next
RDB_Last = rng.Find(What:="*", _
after:=rng.cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
Case 2:
On Error Resume Next
RDB_Last = rng.Find(What:="*", _
after:=rng.cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
Case 3:
On Error Resume Next
lrw = rng.Find(What:="*", _
after:=rng.cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
On Error Resume Next
lcol = rng.Find(What:="*", _
after:=rng.cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
On Error Resume Next
RDB_Last = rng.Parent.cells(lrw, lcol).Address(False, False)
If Err.Number > 0 Then
RDB_Last = rng.cells(1).Address(False, False)
Err.Clear
End If
On Error GoTo 0
End Select
End Function
