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

'http://www.excelpx.com/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 AsADODB.Connection

    Dim Sht As Worksheet

    Set Sht = ActiveSheet

   Sht.[a3:m1000].ClearContents

    nm1 = ThisWorkbook.Name

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

    While Not Len(sh) = 0And 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;';datasource=" & 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