18，用Dir提取多工作簿数据 （ADO）

'18，用Dir提取多工作簿数据 （ADO）

'http://www./dispbbs.asp?boardid=5&id=135431&star=1#1862014

'发料一.xls   需要先引用Ado 2.7

Sub 多工作簿提取数据()

'2010-7-21

    Dim sh As String, nm$, m%, Myr&, i&, n&, nm1$

    Dim Sql$, conn As ADODB.Connection

    Dim Sht As Worksheet

    Set Sht = ActiveSheet

    Sht.[a3:m1000].ClearContents

    nm1 = ThisWorkbook.Name

    sh = Dir(ThisWorkbook.PATH & "\*.xls")

    While Not Len(sh) = 0 And sh <> nm1

        Set conn = New ADODB.Connection

        nm = ThisWorkbook.PATH & "\" & sh

        With conn

            .Provider = "microsoft.jet.oledb.4.0"

            .ConnectionString = "Extended Properties='Excel 8.0;hdr=yes;imex=1;';data source=" & nm

            .Open

        End With

        Sql = "select * from [生产领用明细表$a2:m1000] "

        n = Sht.[a65536].End(xlUp).Row + 1

        Sht.Cells(n, 1).CopyFromRecordset conn.Execute(Sql)

        sh = Dir

        conn.Close

    Wend

    Set conn = Nothing

End Sub