Merge 10 xls files into one

Sub ReadXLFiles()
'set a reference (in Tools / References) to Microsoft ActiveX Data Objects
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim strConnect As String
Dim strSQL As String
Dim recCount As Long
Dim ws As Worksheet
Dim wsTgt As Worksheet
Dim strFileName As String
Dim strFilePath As String
Dim bNeedToWriteHeaders As Boolean
Dim rngTgt As Range
Dim c As Integer

    On Error GoTo ErrorHandler
    Set cn = New ADODB.Connection
    Set rs = New ADODB.Recordset
    Set wsTgt = ActiveSheet
    Set rngTgt = wsTgt.Range("A1")
    ' clear existing data
    rngTgt.CurrentRegion.Clear
    
    strFilePath = ActiveWorkbook.Path
    
    Application.Calculation = xlCalculationManual
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    strFileName = Dir(strFilePath & "\*.xls*")
    strSQL = "SELECT * FROM [Sheet1$]"
    ' assumes all workbooks have a "Sheet1" where the data is located
    recCount = 0
    bNeedToWriteHeaders = True
    Do While strFileName <> ""
        If strFileName <> ActiveWorkbook.Name Then
            Application.StatusBar = "Processing file: " & strFileName
            strConnect = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strFilePath & "\" & strFileName & ";Extended Properties=Excel 12.0;Persist Security Info=False"
            
            cn.Open strConnect
            cn.CommandTimeout = 120
            
            'run the query
            rs.Open strSQL, cn, adOpenKeyset  'need this for record number
            If rs.RecordCount > 0 Then
                If bNeedToWriteHeaders Then
                    For c = 0 To rs.Fields.Count - 1
                        rngTgt.Offset(0, c) = rs.Fields(c).Name
                    Next
                    bNeedToWriteHeaders = False
                    recCount = recCount + 1
                End If
                'write the results
                rngTgt.Offset(recCount, 0).CopyFromRecordset rs
                'update position for next write
                recCount = recCount + rs.RecordCount
            End If
            DoEvents
            rs.Close
            cn.Close
        End If
        strFileName = Dir  ' get next file name
    
    Loop
    
    Set rs = Nothing
    Set cn = Nothing
    
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.StatusBar = False
    
    MsgBox "Done.", vbExclamation, "Thanks Pat!"
Exit Sub

ErrorHandler:
    MsgBox Err.Description, vbCritical, "I'm sorry Dave, I can't do that..."
End Sub