怎样把提取多个工作薄多个工作表符合条件的相关内容

chymmych

每个月都有十几二十份这样的工作薄,每个工作薄里面又有几十个工作表,现在所需要就是要提取工作表里面小计的相关数据,形成汇总表,麻烦帮下忙

蓝桥玄霜

请见代码。

chymmych

我试一下,谢谢老师

魂断蓝桥

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
   

kszcs

蓝桥玄霜 发表于 2016-9-19 09:57
请见代码。

代码简明易懂，谢谢版主

chymmych

蓝桥玄霜 发表于 2016-9-19 09:57
请见代码。

Sub lqxs()
    Dim Arr, myPath$, myName$, bt, jyh$
    Dim sh As Worksheet, nm$, Brr(1 To 50000，1 To 5), n&
    Application.ScreenUpdating = False
    Sheet1.Activate
    Cells.ClearContents
    bt = Array("日期", "客户名称", "订单号", "集约号", "金额")
    [a1].Resize(1, UBound(bt) + 1) = bt
    myPath = ThisWorkbook.Path & "\"
    myName = Dir(myPath & "*.xls?")
    Do While myName <> ""
        If InStr(myName, "汇总") = 0 Then
        With GetObject(myPath & myName)
            For Each sh In .Sheets
               jyh = Mid(sh.Name, 5)
               Arr = sh.UsedRange
               If UBound(Arr) > 10 Then
                  rq = Arr(4, 3): mc = Arr(8, 3)
                  For i = 10 To UBound(Arr)
                     If Arr(i, 3) = "小计" Then
                        n = n + 1
                        Brr(n, 1) = rq: Brr(n, 2) = mc: Brr(n, 3) = Arr(i, 2): Brr(n, 4) = jyh: Brr(n, 5) = Arr(i, 8)
                     End If
                  Next
              End If
          Next
          .Close False
      End With
      End If

我运行时，提示对象不支持该属性或方法

蓝桥玄霜

建议上传出错的附件看看。

chymmych

蓝桥玄霜 发表于 2016-9-20 09:50
建议上传出错的附件看看。

麻烦老师了

kszcs

chymmych 发表于 2016-9-20 10:52
麻烦老师了

    Loop
    Columns("A:D").numberformatlacal = "@"
改为
    Loop
    Columns("A:D").numberformatlocal = "@"

chymmych

kszcs 发表于 2016-9-20 17:27
Loop
    Columns("A:D").numberformatlacal = "@"
改为

谢谢大神，我真是粗心！