Vba+Sql汇总多工作簿多工作表

Sub 多工作簿工作表汇总()

    Dim Cnn As Object, Rst As Object, Rs As Object, FilePath$, FullName$, FullPath$, Sql$, Sht_Name$, i&

    Set Cnn = CreateObject("ADODB.Connection")

    Set Rst = CreateObject("ADODB.Recordset")

    FilePath = ThisWorkbook.Path

    FullName = Dir(FilePath & "\*.xls*")

    Do While FullName <> ""

        If FullName <> ThisWorkbook.Name Then

            FullPath = FilePath & "\" & FullName

            Cnn.Open "Provider=Microsoft.Ace.Oledb.12.0;Extended Properties=Excel 12.0;Data Source=" & FullPath

            Set Rst = Cnn.OpenSchema(20)

            Do Until Rst.EOF

                Sht_Name = Rst("TABLE_NAME").Value

                If Sql = "" Then

                    Sql = "select * from [" & FullPath & "].[" & Sht_Name & "]"

                Else

                    Sql = Sql & " Union all select * from [" & FullPath & "].[" & Sht_Name & "]"

                End If

                Rst.MoveNext

            Loop

            Rst.Close

            Cnn.Close

        End If

        FullName = Dir

    Loop

    Cnn.Open "Provider=Microsoft.Ace.Oledb.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName

    Set Rs = Cnn.Execute(Sql)

    For i = 0 To Rs.Fields.Count - 1

        Cells(1, i + 1).Value = Rs.Fields(i).Name

    Next i

    [a2].CopyFromRecordset Rs

    Cnn.Close

    Set Rs = Nothing

    Set Rst = Nothing

    Set Cnn = Nothing

End Sub