提取多个工作薄多个工作表符合条件的相关内容代码VBA

​Option Explicit

Sub a()
Dim arr(), mypath$, myfile$, i%
mypath = ThisWorkbook.Path & "\"
myfile = Dir(mypath & "*.xlsm")
Do While myfile <> ""
    If myfile <> ThisWorkbook.Name And Left(myfile, 1) <> "~" Then
        i = i + 1
        ReDim Preserve arr(1 To i)
        arr(i) = myfile
    End If
        myfile = Dir()
Loop
Dim rs As Object, MyTable As Object, t%, cnn, s$, brr(1 To 9999, 1 To 3)
Set cnn = CreateObject("adodb.connection")
For i = 1 To UBound(arr)
    cnn.Open "Provider=Microsoft.ACE.OleDb.12.0;Extended Properties='Excel 12.0;HDR=YES'; Data Source=" & mypath & arr(i)
    Set rs = cnn.OpenSchema(20)
    Do Until rs.EOF
        If rs.Fields("TABLE_TYPE") = "TABLE" Then
                s = rs("TABLE_NAME").Value
                If Right(s, 1) = "$" Then
                    t = t + 1
                    brr(t, 1) = mypath & arr(i)
                    brr(t, 2) = Replace(s, "$", "")
                    brr(t, 3) = Mid(brr(t, 2), 5)
                End If
        End If
                rs.MoveNext
            Loop
            cnn.Close
Next
Dim SQL$, x&, y As Integer, m&, tmp1, tmp2
Dim j%, drr, zrr(1 To 99999, 1 To 5)
    For j = 1 To t
        Set cnn = CreateObject("ADODB.Connection")
        cnn.Open "Provider=Microsoft.ace.OleDb.12.0;Extended Properties='Excel 8.0;HDR=NO'; Data Source=" & brr(j, 1)
    SQL = "select * from [" & brr(j, 2) & "$c4:c4]"
    tmp1 = cnn.Execute(SQL)(0)
    SQL = "select * from [" & brr(j, 2) & "$c8:c8]"
    tmp2 = cnn.Execute(SQL)(0)
    SQL = "select """ & tmp1 & """,""" & tmp2 & """,""" & brr(j, 3) & """,F1,F7 from [" & brr(j, 2) & "$B11:H] WHERE F2='小计'"
    Set rs = cnn.Execute(SQL)
        drr = rs.getRows
           For m = 0 To UBound(drr, 2)
                x = x + 1
                For y = 1 To UBound(drr) + 1
                    zrr(x, y) = drr(y - 1, m)
                Next
            Next
    Next
Set cnn = Nothing
Set rs = Nothing
[a2:e99999].ClearContents
[a2].Resize(x, 5) = zrr
End Sub