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?

1. Copy above macro
2. Go to VBA Editor (Alt+F11)
3. Click "Insert" on the top menu
4. Click "Module" to insert a module to your workbook
5. Paste code into the code window
6. 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.

1. Click "File" on the menu, or if you have an earlier version of Excel, click the office button.
2. Click "Save As"
3. Click file extension drop-down list
   
4. Change the file extension to "Excel Macro-Enabled Workbook (*.xlsm)".
   

How to use the macro?

1. Open the Macro dialog box (Alt + F11)
   
2. Select CopWKBooksInFolder.
3. Click "Run" button.
4. A folder dialog box appears.
   
5. Navigate to a folder you want to search.
6. Click OK button.
7. 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

---

Weekly Blog EMAIL

Email

Welcome! I am Oscar and here to help you out.

Feel free to comment and ask Excel questions.

Make sure you subscribe to my newsletter so you don't miss new blog articles.

Related articles

---

Working with FILES

What's on this page Copy a file Copy and rename a file Rename a file List files in a folder […]

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 […]

How to change a picture in a worksheet dynamically [VBA]

Rahul asks: I want to know how to create a vlookup sheet, and when we enter a name in a […]

How to copy non contiguous cell ranges

If you try to copy multiple cell ranges on a worksheet that don't have the same number of rows or […]