Macro to merge all excel files from a folder + its subfolders

[Yogibear88]

Hi, I've been trying to find a macro that consolidates all excel files within a selected folder + its subfolders.
The code needs to consolidate the data under the same header rows into a master worksheet, and if there are new headers in other files, these will be added as new columns to the right of the master worksheet and data appended accordingly.

So far, my code has only been able to consolidate from the selected folder, but it does not loop through the subfolders for the other excel files. Subfolders can be named randomly, as do the excel files within.

Appreciate if anyone can help to modify the code to loop through the subfolders. I've tried using the FSO method but not able to succeed.

Sub MergeExcelFileVer4()

Application.AskToUpdateLinks = False
Application.DisplayAlerts = False

Dim WS As Worksheet
Dim myfolder As String
Dim Str As String
Dim a As Single
Dim sht As Worksheet
Dim rngHdr As Range, HdrsToCopy As Range, DestRow As Range
Dim AllHeaders()
ReDim AllHeaders(0 To 0)

With ThisWorkbook
  Set DestSheet = .Sheets.Add(after:=.Sheets(.Sheets.Count))
End With  'thisworkbook
With DestSheet
  Set DestRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1)  'or any other column.
End With  'DestSheet

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
            rowscount = sht.UsedRange.Rows.Count - 1
            For Each cll In sht.Rows(1).SpecialCells(xlCellTypeConstants, xlTextValues).Cells
            NewHeader = False
            HeaderColumn = 0
            For i = LBound(AllHeaders) To UBound(AllHeaders)
            If AllHeaders(i) = cll.Value Then
                HeaderColumn = i
            Exit For
          End If
        Next i
        If HeaderColumn = 0 Then
          If UBound(AllHeaders) = 0 Then ReDim AllHeaders(1 To UBound(AllHeaders) + 1) Else ReDim Preserve AllHeaders(1 To UBound(AllHeaders) + 1)
          AllHeaders(UBound(AllHeaders)) = cll.Value
          HeaderColumn = UBound(AllHeaders)
          NewHeader = True
        End If
        If NewHeader Then DestSheet.Cells(1, HeaderColumn).Value = AllHeaders(HeaderColumn)
        cll.Offset(1).Resize(rowscount).Copy DestRow.Offset(, HeaderColumn - 1)
        Next cll
            Set DestRow = DestRow.Offset(rowscount)
        Next sht
        End If
        Workbooks(Value).Close False
        On Error GoTo 0
    End If
End If
Value = Dir
Loop

Application.DisplayAlerts = True
Application.AskToUpdateLinks = True

End Sub

 

[yinkajewole]

Can you give this a try?

Dim WS As Worksheet
Dim myFolder As String
Dim Str As String
Dim a As Single
Dim sht As Worksheet
Dim rngHdr As Range, HdrsToCopy As Range, DestRow As Range
Dim AllHeaders()


Sub MergeExcelFileVer4()

Application.AskToUpdateLinks = False
Application.DisplayAlerts = False


With ThisWorkbook
  Set DestSheet = .Sheets.Add(after:=.Sheets(.Sheets.Count))
End With  'thisworkbook
With DestSheet
  Set DestRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1)  'or any other column.
End With  'DestSheet


With Application.FileDialog(msoFileDialogFolderPicker)
    .Show
    myFolder = .SelectedItems(1) & "\"
End With
LoopAllSubFolders myFolder

Application.DisplayAlerts = True
Application.AskToUpdateLinks = True

End Sub
Sub LoopAllSubFolders(ByVal folderPath As String)
ReDim AllHeaders(0 To 0)
Dim fileName As String
Dim fullFilePath As String
Dim numFolders As Long
Dim folders() As String
Dim i As Long

If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
fileName = Dir(folderPath & "*.xl*", vbDirectory)

While Len(fileName) <> 0

    If Left(fileName, 1) <> "." Then
 
        fullFilePath = folderPath & fileName
 
        If (GetAttr(fullFilePath) And vbDirectory) = vbDirectory Then
            ReDim Preserve folders(0 To numFolders) As String
            folders(numFolders) = fullFilePath
            numFolders = numFolders + 1
        Else

            Workbooks.Open fileName:=fullFilePath, Password:="zzzzzzzzzzzz"
            If Err.Number > 0 Then
            Else
                On Error GoTo 0
          
            For Each sht In ActiveWorkbook.Worksheets
            rowscount = sht.UsedRange.Rows.Count - 1
            For Each cll In sht.Rows(1).SpecialCells(xlCellTypeConstants, xlTextValues).Cells
            NewHeader = False
            HeaderColumn = 0
            For i = LBound(AllHeaders) To UBound(AllHeaders)
            If AllHeaders(i) = cll.Value Then
                HeaderColumn = i
            Exit For
          End If
        Next i
        If HeaderColumn = 0 Then
          If UBound(AllHeaders) = 0 Then ReDim AllHeaders(1 To UBound(AllHeaders) + 1) Else ReDim Preserve AllHeaders(1 To UBound(AllHeaders) + 1)
          AllHeaders(UBound(AllHeaders)) = cll.Value
          HeaderColumn = UBound(AllHeaders)
          NewHeader = True
        End If
        If NewHeader Then DestSheet.Cells(1, HeaderColumn).Value = AllHeaders(HeaderColumn)
        cll.Offset(1).Resize(rowscount).Copy DestRow.Offset(, HeaderColumn - 1)
        Next cll
            Set DestRow = DestRow.Offset(rowscount)
        Next sht
        End If
        Workbooks(fileName).Close False
        On Error GoTo 0
        End If
 
    End If
 
    fileName = Dir()

Wend

For i = 0 To numFolders - 1

    LoopAllSubFolders folders(i)
 
Next i

End Sub