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.
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.
Macro VBA code
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 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 sht.Range("A1").CurrentRegion.Copy Destination:=WS.Range("A" & Lrow) 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
Where to copy the code?
- Copy above macro
- Go to VBA Editor (Alt+F11)
- Click "Insert" on the top menu
- Click "Module" to insert a module to your workbook
- Paste code into the code window
- Exit VBA Editor and return to Excel (Alt+Q)
Save your 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.
- Click "File" on the menu, or if you have an earlier version of Excel, click the office button.
- Click "Save As"
- Click file extension drop-down list
- Change the file extension to "Excel Macro-Enabled Workbook (*.xlsm)".
How to use the macro?
- Open the Macro dialog box (Alt + F11)
- Select CopWKBooksInFolder.
- Click "Run" button.
- A folder dialog box appears.
- Navigate to a folder you want to search.
- Click 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.
Copy data except 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
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
Search all workbooks in a folder
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 article demonstrates a macro that copies values between sheets. I am using the invoice template workbook. This macro copies […]
Open Excel files in a folder [VBA]
This tutorial shows you how to list excel files in a specific folder and create adjacent checkboxes, using VBA. The […]
Split data across multiple sheets [VBA]
In this post I am going to show how to create a new sheet for each airplane using vba. The […]
Search all workbooks in a folder
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 article demonstrates a macro that copies values between sheets. I am using the invoice template workbook. This macro copies […]
Apply dependent combo box selections to a filter
Josh asks: now if i only knew how to apply these dependent dropdown selections to a filter, i'd be set. […]
2 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 ?