Summary - Copy the columns based on column headers

I need help to combine multiple workbook(with a single sheet) to a summary sheet using a macro.
I need to combine Book1.xls and Book2.xls to form Summary.xls as attached. There will be multiple books.
All the books will be in the same directory.

The summary.xls sheet will have all the columns from Book1 and Book 2. There will be only four columns all together in Summary sheet
The summary sheet and columns in summary sheet will exist and will not be created by macro.

Need a Macro:
to copy the columns from book1 and book2 based on column header in Summary sheet and paste it in Summary sheet on the corresponding columns.

So the macro will be like
The column header will be stored in a array(No, State, Employee Name, Type)

Step:
will read book1 for No first and if it exist will copy to Summary Column 1 then will read book1 for State and if it exist will copy Summary Column2 and it
will go till the Type. As Type is not found in Book1 that column will be left empty.

Should do the Step for book2.


Thank you.

This below code will do exactly what is required. The summary workbook should have a sheet named sheet1.

Dim dic             As Object
Dim Counter         As Long
Sub ConsolidateWorkbooks()
    
    Dim r           As Long
    Dim c           As Long
    Dim n           As Long
    Dim j           As Long
    Dim Fldr        As String
    Dim Fname       As String
    Dim wbkActive   As Workbook
    Dim wbkSource   As Workbook
    Dim Dest        As Range
    Dim d, k()
    
    '// User settings
    Const SourceFileType        As String = "xls*"  'xls,xlsx,xlsb,xlsm
    Const DestinationSheet      As String = "Sheet1"
    Const DestStartCell         As String = "A1"
    Const MaxRows               As Long = 50000
    Const MaxCols               As Long = 100
    Const StartRow              As Long = 2
    '// End
    
    Application.ScreenUpdating = False
    Counter = 0
    With Application.FileDialog(4)
        .Title = "Select source file folder"
        .AllowMultiSelect = False
        If .Show = -1 Then
            Fldr = .SelectedItems(1)
        Else
            GoTo Xit
        End If
    End With
    
    
    Set dic = CreateObject("scripting.dictionary")
        dic.comparemode = 1
    
    Set wbkActive = ThisWorkbook
    
    ReDim k(1 To MaxRows, 1 To MaxCols)
    
    Set Dest = wbkActive.Worksheets(DestinationSheet).Range(DestStartCell)
    
    Fname = Dir(Fldr & "\*." & SourceFileType)
    
    Do While Len(Fname)
        If wbkActive.Name <> Fname Then
            Set wbkSource = Workbooks.Open(Fldr & "\" & Fname)
            With wbkSource.Worksheets(1)
                d = .Range("a1").CurrentRegion
                UniqueHeaders Application.Index(d, 1, 0)
                For r = StartRow To UBound(d, 1)
                    If Len(d(r, 1)) Then
                        n = n + 1
                        For c = 1 To UBound(d, 2)
                            If Len(Trim$(d(1, c))) Then
                                j = dic.Item(Trim$(d(1, c)))
                                k(n, j) = d(r, c)
                            End If
                        Next
                    End If
                Next
                Erase d
            End With
            wbkSource.Close 0
            Set wbkSource = Nothing
        End If
        Fname = Dir()
    Loop
    
    If n Then
        Dest.Resize(, dic.Count) = dic.keys
        Dest.Offset(1).Resize(n, dic.Count) = k
        MsgBox "Done", vbInformation, "ExcelFox.com"
    End If
Xit:
    Application.ScreenUpdating = True
    
End Sub
Private Sub UniqueHeaders(ByRef DataHeader)
    
    Dim i   As Long
    Dim j   As Long
    
    With Application
        j = .ScreenUpdating
        .ScreenUpdating = False
    End With
    
    For i = LBound(DataHeader) To UBound(DataHeader)
        If Len(Trim$(DataHeader(i))) Then
            If Not dic.exists(Trim$(DataHeader(i))) Then
                Counter = Counter + 1
                dic.Add Trim$(DataHeader(i)), Counter
            End If
        End If
    Next
    
    Application.ScreenUpdating = j
    
End Sub

The above macro solved my requirement. I need help in the above macro

to check the excel file in sub-folders also. It currently checks the excel file only in the current folder.

Thanks