ado遍历文件夹及获取工作表名

ado 遍历文件，获取工作表名 相关过程

Sub ado查询() 'by feiren228
    Application.ScreenUpdating = False
    t1 = Timer
    Dim FSO As Object, Folder As Object, arr$(), brr(10000, 99), ary, m&, i&, j&, l&, cnn As Object, sql$, s$, p$
    Dim bm$(), f$, bt, jgzd$, cxzd$, hd, sqlzd, ks&
    Set dic = CreateObject("scripting.dictionary")
    hd = Array(, "生产日期", "处理结果", "产品名称", "产品编码", "防伪码", "入库", "生产部门", "生产车间", "质检员", "备注")
    For i = 1 To UBound(hd)
        dic(hd(i)) = "f" & i
    Next
    bt = [a5:h5]: jgzd = dic(bt(1, 1))
    For j = 2 To UBound(bt, 2)
        jgzd = jgzd & "," & dic(bt(1, j))
    Next
    Col% = Rows(2).Find("*", , xlValues, xlWhole, xlByColumns, xlPrevious).Column
    bt = [a2].Resize(2, Col): m = 0
    For j = 1 To UBound(bt, 2)
        If Len(bt(2, j)) Then
            m = m + 1
            If m = 1 Then cxzd = dic(bt(1, j)) & "='" & Trim(bt(2, j)) & "'" Else cxzd = cxzd & " and " & dic(bt(1, j)) & "='" & Trim(bt(2, j)) & "'"
        End If
    Next
    'Debug.Print jgzd
    ' Debug.Print cxzd
    p = ThisWorkbook.Path
    Set cnn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("adodb.recordset")
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Folder = FSO.GetFolder(p): m = 0
    Call GetFiles(Folder, arr, m, p)  '存储文件路径
    If Application.Version = "11.0" Then
        cnn.Open "Provider=Microsoft.jet.OLEDB.4.0;Extended Properties='Excel 8.0;imex=1;hdr=no';Data Source=" & ThisWorkbook.FullName
    Else
        cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;imex=1;hdr=no';Data Source=" & ThisWorkbook.FullName
    End If
    [a6:j65536].ClearContents
    For i = 1 To UBound(arr)
        '===================循环处理文件============================
        m = 0: Erase bm
        Call gettab(bm, arr(i), m)
        For j = 1 To UBound(bm)
            sql = "select " & jgzd & " from [Excel 8.0;imex=1;hdr=no;Database=" & arr(i) & "].[" & bm(j) & "$A4:J] where " & cxzd
            'Debug.Print sql
            Set rs = cnn.Execute(sql)
            If Not rs.EOF Then
                r = Range("a:a").Find("*", , xlValues, xlWhole, xlByRows, xlPrevious).Row + 1
                ks = r
                'r = Cells(Rows.Count, 1).End(3).Row + 1
                Cells(r, 1).CopyFromRecordset rs
                r = Range("a:a").Find("*", , xlValues, xlWhole, xlByRows, xlPrevious).Row + 1
                Range("i" & ks).Resize(r - ks) = arr(i): Range("j" & ks).Resize(r - ks) = bm(j)
            End If
        Next j
    Next i
    rs.Close
    cnn.Close
    Set rs = Nothing
    Set cnn = Nothing
    MsgBox "查询完成！" & vbCrLf & "查询共计用时：" & vbCrLf & Format(Timer - t1, "0.0000秒！"), , "时间统计"
    Application.ScreenUpdating = True
End Sub
'================遍历文件夹=================

Sub GetFiles(arr$(), m%, ByVal p$)
    'p为遍历的路径，arr为存储文件路径数组
    Dim SubFolder As Object
    Dim File As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Folder = FSO.GetFolder(p)
    For Each File In Folder.Files
        If File.Name Like "*.xls*" Then
            m = m + 1
            ReDim Preserve arr(1 To m)
            arr(m) = File
        End If
    Next
    For Each SubFolder In Folder.SubFolders
        Call GetFiles(arr, m, SubFolder.Path)
    Next
End Sub

'==========获取工作表名================
Function GetTab(f$)
    'f为文件路径
    Dim conn As Object, rst As Object, s$, m%, bm$()
    m = 0
    Set conn = CreateObject("ADODB.Connection")
    Set rst = CreateObject("adodb.recordset")
    conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & f
    Set rst = conn.OpenSchema(20)   'Set rst = conn.OpenSchema(adSchemaTables)，创建数据表记录集
    Do Until rst.EOF
        If rst.Fields("TABLE_TYPE") = "TABLE" Then
            m = m + 1
            ReDim Preserve bm(1 To m)
            s = Replace(rst("TABLE_NAME").Value, "'", "")              '去除"’"(数字工作表）
            If Right(s, 1) = "$" Then bm(m) = Left(s, Len(s) - 1)     '去除$号
        End If
        rst.MoveNext
    Loop
    GetTab = bm
    rst.Close
    conn.Close
    Set rst = Nothing
    Set conn = Nothing
End Function