Sub test()
    Dim myDir As String, fn As String, i As Long, s(1)
    Dim cn As Object, rs As Object, x As Long
    Const wsName As String = "owssvr"
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then myDir = .SelectedItems(1) & "\"
    End With
    If myDir = "" Then Exit Sub
    fn = Dir(myDir & "*.xlsx")
    Set cn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")
    cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & myDir & fn & ";Extended Properties=""Excel 12.0;"""
    With Sheets("expected output")
        .[a1].CurrentRegion.ClearContents
        s(0) = Filter(Sheets("Column header").[transpose(if(a1:a1000<>"",a1:a1000))], False, 0)
        .[a1].Resize(, UBound(s(0)) + 1) = s(0)
        Do While fn <> ""
            s(1) = Cols("'" & myDir & "[" & fn & "]" & wsName & "'", s(0))
            If s(1) <> "" Then
                rs.Open "Select " & s(1) & " From " & _
                    "`Excel 12.0;DataBase=" & myDir & fn & "`.`" & wsName & "$`;", cn
                x = .Evaluate("max(if(" & .[a1].Address & "<>"""",row(" & .[a1].CurrentRegion.Address & ")))")
                .Range("a" & x + 1).CopyFromRecordset rs
                rs.Close
            End If
            fn = Dir
        Loop
    End With
End Sub

Function Cols(fn, s) As String
    Dim e, x, flg As Boolean
    If IsError(ExecuteExcel4Macro(fn & "!r1c1")) Then Exit Function
    For Each e In s
        x = ExecuteExcel4Macro("match(""" & e & """," & fn & "!r1:r1,0)")
        If IsError(x) Then
            Cols = Cols & ", Null"
        Else
            Cols = Cols & ", `" & Replace(e, ".", "#") & "`": flg = True
        End If
    Next
    If Not flg Then Exit Function
    If InStr(Cols, "`") = 3 Then Cols = Mid$(Cols, 3) Else Cols = Mid$(Cols, 2)
End Function