相同格式EXCEL汇总

以下VBA用以汇总相同格式的工作表.

Option Explicit
Sub Collection()
'Collection Data into TTL worksheet
Dim Sh As Worksheet, SQL$, m%, Conn As Object
Dim MaxClm&, TitleArr()
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Set Conn = CreateObject("adodb.connection")
Conn.Open "provider=microsoft.jet.oledb.4.0;extended properties='excel 8.0;imex=1';data source=" & ActiveWorkbook.FullName
Application.ScreenUpdating = False  'Unable Screen Update
Application.DisplayAlerts = False   'No Alert for TTL sheet delete
For Each Sh In Sheets
   '查找现有WORKBOOK，如果已经有汇总表-TTL,删除
   If Sh.Name = "TTL" Then Sheets("TTL").Delete
Next
'增加新的汇总表-TTL
Set Sh = Sheets.Add(After:=Sheets(Sheets.Count))
Sh.Name = "TTL"
Application.DisplayAlerts = True    'Alert enable

With Sheets("TTL")
.UsedRange.ClearContents    'Clear data
MaxClm = Sheet1.[AX1].End(xlToLeft).Column  'Last column
'从SHEET1读入标题栏
TitleArr = Sheet1.Range("A1").Resize(1, MaxClm)
'循环SHEET
For Each Sh In Sheets
    If Sh.Name <> "TTL" Then
        m = m + 1
        If m = 1 Then
            SQL = "select '" & Sh.Name & "',* from [" & Sh.Name & "$A:J]"
        Else
            SQL = SQL & " union all select '" & Sh.Name & "',* from [" & Sh.Name & "$A:J]"
        End If
    End If
Next
SQL = "select * from (" & SQL & ") "
'执行QUERY
.Range("A2").CopyFromRecordset Conn.Execute(SQL)
'读入标题栏
.Cells(1, 1) = "WorkSheet"
.Range("B1").Resize(1, UBound(TitleArr, 2)) = TitleArr

'释放内存
Conn.Close: Set Conn = Nothing
'UpdateScreen
Application.ScreenUpdating = True
End With
End Sub