2018-10-23

Option Explicit

Sub 按钮2_Click()

    Dim d, j&, cn, T As Double, sql$, MyPath$, MyFiles$, TWb$, bm$, m&, nm&

    Application.ScreenUpdating = False

    T = Timer

    Range([A4], [H65536].End(3).Offset(1)).Clear

    Set d = CreateObject("scripting.dictionary")

    Set cn = CreateObject("ADODB.Connection")

    TWb = ThisWorkbook.Name

    MyPath = ThisWorkbook.Path

    MyFiles = Dir(MyPath & "\*.xls")

    Do While MyFiles <> ""

        If TWb <> MyFiles Then

            m = m + 1

            bm = Replace(MyFiles, ".xls", "")

            For j = 1 To 3

                sql = "Select """ & bm & """ ,""" & j & "部门"" ,* From [excel 8.0;HDR=NO;DATABASE=" & MyPath & "\" & MyFiles & "].[" & j & "部门$]"

                d(sql) = ""

            Next

            If m Mod 16 = 0 Then

                sql = Join(d.Keys, " UNION ALL ")

                sql = "SELECT F1,F2,F3,F4,F5,F6,EXPR1000,EXPR1001 from (" & sql & ") WHERE F2 = '" & Cells(2, 3).Value & "'"

                sql = Replace(sql, "[excel 8.0;HDR=NO;DATABASE=" & MyPath & "\" & MyFiles & "].", "")

                cn.Open "provider=microsoft.jet.oledb.4.0;extended properties='excel 8.0;hdr=no';data source=" & MyPath & "\" & MyFiles

                [a65536].End(3).Offset(1).CopyFromRecordset cn.Execute(sql)

                cn.Close

                d.RemoveAll

                nm = nm + 1

            End If

        End If

        MyFiles = Dir

    Loop

    Set cn = Nothing: Set d = Nothing

    Application.ScreenUpdating = True

    MsgBox "取数" & nm & "次;耗时" & Timer - T & "秒"

End Sub