Copy data from workbooks in folder and subfolders
I will in this article demonstrate a macro that automatically opens all workbooks in a folder and subfolders, one by one, and gets data from each sheet copied to a master workbook.
This allows you to quickly merge data across multiple workbooks saving you a lot of time and effort. To be able to consolidate data you need to make sure that data in each sheet begins in cell A1.
Table of Contents
The macro selects the current region based on cell A1 in each sheet, then copies the cell range to the master sheet in a new workbook.
For this to work the cells must be contiguous meaning there can't be blank rows or columns in the dataset.
The macro can, however, easily be modified to get a range based on the last non-empty cell in column A.
1. Macro VBA code
'Name macro
Sub CopWKBooksInFolder()
'Dimension variables and declare data types
Dim WS As Worksheet
Dim myfolder As String
Dim Str As String
Dim a As Single
Dim sht As Worksheet
'Insert a new worksheet programmatically
Set WS = Sheets.Add
'Show dialog box and prompt the user for a folder
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
myfolder = .SelectedItems(1) & "\"
End With
'Dir function returns a string representing the name of a file or folder that matches a specified pattern.
Value = Dir(myfolder)
'Iterate through all files in folder
Do Until Value = ""
'Check that file name is not . (dot) or .. (two dots)
If Value = "." Or Value = ".." Then
'Continue here if file name is not . (dot) or .. (two dots)
Else
'Check if file extension matches xls, xlsx or xlsm
If Right(Value, 3) = "xls" Or Right(Value, 4) = "xlsx" Or Right(Value, 4) = "xlsm" Then
'Enable error handling
On Error Resume Next
'Check if file is password protected
Workbooks.Open Filename:=myfolder & Value, Password:="zzzzzzzzzzzz"
'Check if an error has occurred
If Err.Number > 0 Then
'Continue here if an error has not occureed
Else
'Disable error handling
On Error GoTo 0
'Iterate through each worksheet in active workbook
For Each sht In ActiveWorkbook.Worksheets
'Check if first cell A1 is not empty
If sht.Range("A1") <> "" Then
'Find last non-empty cell in column A
Lrow = WS.Range("A" & Rows.Count).End(xlUp).Row + 1
'Copy cells
sht.Range("A1").CurrentRegion.Copy Destination:=WS.Range("A" & Lrow)
End If
'Continue with the next worksheet
Next sht
End If
'Close active workbook
Workbooks(Value).Close False
'Disable error handling
On Error GoTo 0
End If
End If
Value = Dir
'Continue with next file
Loop
'Adjust column width
Cells.EntireColumn.AutoFit
End Sub
2. Where to copy the code?
- Copy above macro
- Go to VBA Editor (Alt+F11)
- Press with left mouse button on "Insert" on the top menu
- Press with left mouse button on "Module" to insert a module to your workbook
- Paste code into the code window
- Exit VBA Editor and return to Excel (Alt+Q)
3. Save the workbook
To be able to use the macro next time you open your workbook you need to save the workbook as a macro-enabled workbook.
- Press with left mouse button on "File" on the menu, or if you have an earlier version of Excel, press with left mouse button on the office button.
- Press with left mouse button on "Save As"
- Press with left mouse button on file extension drop-down list
- Change the file extension to "Excel Macro-Enabled Workbook (*.xlsm)".
4. How to use the macro?
- Open the Macro dialog box (Alt + F11)
- Select CopWKBooksInFolder.
- Press with left mouse button on "Run" button.
- A folder dialog box appears.
- Navigate to a folder you want to search.
- Press with left mouse button on OK button.
- The macro starts opening workbooks, one by one, copying values to a master worksheet.
The picture above demonstrates a master worksheet, even the headers are copied to the worksheet.
5. Copy data ignore headers
The following macro copies all data from the first opened workbook and worksheet, worksheets after that ignores the header row.
There is only one header row in the picture above.
Sub CopWKBooksInFolder()
Dim WS As Worksheet
Dim myfolder As String
Dim Str As String
Dim a As Single
Dim sht As Worksheet
Set WS = Sheets.Add
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
myfolder = .SelectedItems(1) & "\"
End With
chk = 0
Value = Dir(myfolder)
Do Until Value = ""
If Value = "." Or Value = ".." Then
Else
If Right(Value, 3) = "xls" Or Right(Value, 4) = "xlsx" Or Right(Value, 4) = "xlsm" Then
On Error Resume Next
Workbooks.Open Filename:=myfolder & Value, Password:="zzzzzzzzzzzz"
If Err.Number > 0 Then
Else
On Error GoTo 0
For Each sht In ActiveWorkbook.Worksheets
If sht.Range("A1") <> "" Then
Lrow = WS.Range("A" & Rows.Count).End(xlUp).Row + 1
If chk = 0 Then
sht.Range("A1").CurrentRegion.Copy Destination:=WS.Range("A" & Lrow)
chk = 1
Else
Set crng = sht.Range("A1").CurrentRegion
Set crng = crng.Offset(1, 0)
Set crng = crng.Resize(crng.Rows.Count - 1)
crng.Copy Destination:=WS.Range("A" & Lrow)
End If
End If
Next sht
End If
Workbooks(Value).Close False
On Error GoTo 0
End If
End If
Value = Dir
Loop
Cells.EntireColumn.AutoFit
End Sub
6. Copy data from specific worksheets in folders based on paths
This macro ignores header rows except the first one, as well. It also allows you to copy data from worksheets whose names contain a specific text string.
The the macro allows you to select a cell range containing search paths to folders you want to search.
Sub CopWKBooksInFolder()
Dim WS As Worksheet
Dim myfolder As String
Dim Str As String
Dim a As Single
Dim sht As Worksheet
Str = Application.InputBox(prompt:="Search only sheet names containing this string:", Title:="Search worksheet whose name contain this string:", Type:=2)
On Error Resume Next
Set Rng = Application.InputBox(prompt:="Select a cell range containing paths to folders" _
, Title:="Select a cell range", Default:=ActiveCell.Address, Type:=8)
On Error GoTo 0
Set WS = Sheets.Add
For Each cell In Rng
If Dir(cell.Value, vbDirectory) <> "" Then
chk = 0
Value = Dir(cell.Value)
Do Until Value = ""
If Value = "." Or Value = ".." Then
Else
If Right(Value, 3) = "xls" Or Right(Value, 4) = "xlsx" Or Right(Value, 4) = "xlsm" Then
On Error Resume Next
Workbooks.Open Filename:=cell.Value & Value, Password:="zzzzzzzzzzzz"
If Err.Number > 0 Then
Else
On Error GoTo 0
For Each sht In ActiveWorkbook.Worksheets
If InStr(sht.Name, Str) <> 0 Then
If sht.Range("A1") <> "" Then
Lrow = WS.Range("A" & Rows.Count).End(xlUp).Row + 1
If chk = 0 Then
sht.Range("A1").CurrentRegion.Copy Destination:=WS.Range("A" & Lrow)
chk = 1
Else
Set crng = sht.Range("A1").CurrentRegion
Set crng = crng.Offset(1, 0)
Set crng = crng.Resize(crng.Rows.Count - 1)
crng.Copy Destination:=WS.Range("A" & Lrow)
End If
End If
End If
Next sht
End If
Workbooks(Value).Close False
On Error GoTo 0
End If
End If
Value = Dir
Loop
End If
Next cell
Cells.EntireColumn.AutoFit
End Sub
Files and folders category
Today I'll show you how to search all Excel workbooks with file extensions xls, xlsx and xlsm in a given folder for a […]
This tutorial shows you how to list excel files in a specific folder and create adjacent checkboxes, using VBA. The […]
Table of Contents Search for a file in folder and sub folders - User Defined Function Search for a file […]
Macro category
Table of Contents How to create an interactive Excel chart How to filter chart data How to build an interactive […]
Table of Contents Excel monthly calendar - VBA Calendar Drop down lists Headers Calculating dates (formula) Conditional formatting Today Dates […]
Table of contents Save invoice data - VBA Invoice template with dependent drop down lists Select and view invoice - […]
Vba category
Today I'll show you how to search all Excel workbooks with file extensions xls, xlsx and xlsm in a given folder for a […]
Table of Contents How to create an interactive Excel chart How to filter chart data How to build an interactive […]
Table of Contents Excel monthly calendar - VBA Calendar Drop down lists Headers Calculating dates (formula) Conditional formatting Today Dates […]
Excel categories
5 Responses to “Copy data from workbooks in folder and subfolders”
Leave a Reply
How to comment
How to add a formula to your comment
<code>Insert your formula here.</code>
Convert less than and larger than signs
Use html character entities instead of less than and larger than signs.
< becomes < and > becomes >
How to add VBA code to your comment
[vb 1="vbnet" language=","]
Put your VBA code here.
[/vb]
How to add a picture to your comment:
Upload picture to postimage.org or imgur
Paste image link to your comment.
Hello,
I choose your last macro of consolidator and modified it to take filenames that start with "BRIDGE" and headers start from A9 but I does not retrive anything. Any ideea?
Sub CopWKBooksInFolder2()
Dim WS As Worksheet
Dim myfolder As String
Dim Str As String
Dim a As Single
Dim sht As Worksheet
Str = Application.InputBox(prompt:="Search only sheet names containing this string:", Title:="Provide sheet name:", Type:=2)
On Error Resume Next
Set Rng = Application.InputBox(prompt:="Select a cell range containing paths to folders" _
, Title:="Select a cell range", Default:=ActiveCell.Address, Type:=8)
On Error GoTo 0
Set WS = Sheets.Add
For Each cell In Rng
If Dir(cell.Value, vbDirectory) "" Then
chk = 0
Value = Dir(cell.Value)
Do Until Value = ""
If Value = "." Or Value = ".." Then
Else
If Left(Value, 6) = "BRIDGE" Then
On Error Resume Next
Workbooks.Open Filename:=cell.Value & Value
If Err.Number > 0 Then
Else
On Error GoTo 0
For Each sht In ActiveWorkbook.Worksheets
If InStr(sht.Name, Str) 0 Then
If sht.Range("A9") "" Then
Lrow = WS.Range("A" & Rows.Count).End(xlUp).Row + 1
If chk = 0 Then
sht.Range("A9").CurrentRegion.Copy Destination:=WS.Range("A" & Lrow)
chk = 1
Else
Set crng = sht.Range("A9").CurrentRegion
Set crng = crng.Offset(1, 0)
Set crng = crng.Resize(crng.Rows.Count - 1)
crng.Copy Destination:=WS.Range("A" & Lrow)
End If
End If
End If
Next sht
End If
Workbooks(Value).Close False
On Error GoTo 0
End If
End If
Value = Dir
Loop
End If
Next cell
Cells.EntireColumn.AutoFit
End Sub
Hello Oscar,
Hoep you are doing fine.
I copied your last macro code for consolidating files and I adapted to consolidate filenames that start with "BRIDGE" and source files headers from A9 but I cannot manage to retrieve. Any ideea ?
Sub CopWKBooksInFolder2() Dim WS As Worksheet Dim myfolder As String Dim Str As String Dim a As Single Dim sht As Worksheet Str = Application.InputBox(prompt:="Search only sheet names containing this string:", Title:="Provide sheet name:", Type:=2) On Error Resume Next Set Rng = Application.InputBox(prompt:="Select a cell range containing paths to folders" _ , Title:="Select a cell range", Default:=ActiveCell.Address, Type:=8) On Error GoTo 0 Set WS = Sheets.Add For Each cell In Rng If Dir(cell.Value, vbDirectory) <> "" Then chk = 0 Value = Dir(cell.Value) Do Until Value = "" If Value = "." Or Value = ".." Then Else If Left(Value, 6) = "BRIDGE" Then On Error Resume Next Workbooks.Open Filename:=cell.Value & Value If Err.Number > 0 Then Else On Error GoTo 0 For Each sht In ActiveWorkbook.Worksheets If InStr(sht.Name, Str) <> 0 Then If sht.Range("A9") <> "" Then Lrow = WS.Range("A" & Rows.Count).End(xlUp).Row + 1 If chk = 0 Then sht.Range("A9").CurrentRegion.Copy Destination:=WS.Range("A" & Lrow) chk = 1 Else Set crng = sht.Range("A9").CurrentRegion Set crng = crng.Offset(1, 0) Set crng = crng.Resize(crng.Rows.Count - 1) crng.Copy Destination:=WS.Range("A" & Lrow) End If End If End If Next sht End If Workbooks(Value).Close False On Error GoTo 0 End If End If Value = Dir Loop End If Next cell Cells.EntireColumn.AutoFit End SubHey Oscar, Love your work, thanks. I tried using this method, and for some reason it show me only data in the first folder without going threw subfolders. That without manipulating the macro. Any idea?
Hello, Great stuff friend. I am very impressed and grateful. MY question is this:
I would like to copy the data from different files into new sheets in my workbook and using the name of the different files.
I have my files organized as .csv and named appropriately (your help with this in another section worked great). Now I need them imported to the master workbook with little sheets bearing the same names as the files. Thoughts?
Great script - wondering how it would be possible to set the destination worksheet rather a new sheet being created when ran.