Sub Demo1()
Dim Rg As Range
FOLDER$ = ThisWorkbook.Path & "\Data\"
With Cells(1).CurrentRegion
.Offset(1).Clear
Application.ScreenUpdating = False
TITL = Application.Index(.Rows(1).Resize(2).Value, 1)
HDR$ = Join$(TITL)
End With
F$ = Dir(FOLDER & "*.xlsx")
Do Until F = ""
With Workbooks.Open(FOLDER & F).Worksheets(1).Cells(1).CurrentRegion.Rows
If Join(Application.Index(.Item("1:2").Value, 1)) = HDR Then
.Item("2:" & .Count).Copy Cells(Me.Rows.Count, 1).End(xlUp)(2)
Else
ReDim COL&(1 To .Columns.Count)
For C& = 1 To UBound(TITL)
Set Rg = .Item(1).Find(TITL(C), , xlValues, xlPart)
If Rg Is Nothing Then Exit For
COL(Rg.Column) = C
Next
If Not Rg Is Nothing Then
R& = Cells(Me.Rows.Count, 1).End(xlUp).Row + 1
With .Item("2:" & .Count).Columns
For C = 1 To UBound(COL)
.Item(C).Copy Cells(R, COL(C))
Next
End With
End If
End If
.Parent.Parent.Close False
End With
F = Dir
Loop
Set Rg = Nothing
End Sub