Private Sub CommandButton1_Click()
    Dim d As New Dictionary, arr(), i%, j%
    Dim cn As New ADODB.Connection
    Dim rst As New ADODB.Recordset
    Dim cat As New Catalog
    Dim sql$, MyPath$, MyFiles$, TWb$
   
    On Error GoTo Err
    Cells = Empty   '清空单元格数据
    TWb = ThisWorkbook.Name
   
    MyPath = ThisWorkbook.Path
    MyFiles = Dir(MyPath & "\*.xls")
    Do While MyFiles <> ""
        If TWb <> MyFiles Then
            d.Add MyFiles, 0
            j = j + 1
        End If
        MyFiles = Dir
    Loop
   
    If j = 0 Then
        MsgBox "没有文件可合并", , "gvntw"
        Exit Sub
    End If
   
    arr = d.Keys: d.RemoveAll

    For i = 0 To UBound(arr)
        cn.Open "Provider=Microsoft.Jet.OleDb.4.0;Extended Properties=Excel 8.0;Data Source=" & MyPath & "\" & arr(i)
        Set cat.ActiveConnection = cn
        For Each Tabs In cat.Tables
            sql = "Select """ & Replace(arr(i), ".xls", "") & """ as 单位,""" & Replace(Tabs.Name, "$", "") & """ as 月份,* From [Excel 8.0;DATABASE=" & MyPath & "\" & arr(i) & "].[" & Tabs.Name & "]"
            d.Add sql, 0
        Next
        cn.Close
    Next

    sql = Join(d.Keys, " UNION ALL ")
    sql = "SELECT  * from (" & sql & ") order by 姓名,月份"
    cn.Open "Provider=Microsoft.Jet.OleDb.4.0;Extended Properties=Excel 8.0;Data Source=" & arr(0)
    Set rst = cn.Execute(sql)