通过vba统计数据

q360043839

把总表A1内容统计多个表的数据并保存Sheet2中

盼盼198310

....................

清风竹-

请看附件。

gwjkkkkk

Option Explicit
Sub test()
    Dim ar, br(), vResult$(), i&, j&, m&, n&, r&, iStart&
    Dim strFileName$, strPath$, wkb As Workbook
   
    Application.ScreenUpdating = False
    strPath = ThisWorkbook.Path & "\"
    strFileName = Dir(strPath & "*.xls*")
    Do Until strFileName = ""
        If strFileName <> ThisWorkbook.Name Then
            With GetObject(strPath & strFileName)
                r = r + 1
                ReDim Preserve br(1 To r)
                br(r) = .Sheets(1).[A1].CurrentRegion
                .Close False
            End With
        End If
        strFileName = Dir
    Loop
   
    r = 0
    ar = Sheets(1).[A1].CurrentRegion.Value
    ReDim vResult(1 To 10 ^ 5, 1 To 4)
    For i = 2 To UBound(ar)
        For j = 1 To UBound(br)
            For m = 1 To UBound(br(j))
                If br(j)(m, 3) = ar(i, 1) Then
                    r = r + 1
                    For n = 1 To UBound(br(j), 2)
                        vResult(r, n) = br(j)(m, n)
                    Next n
                End If
            Next m
        Next j
    Next i
   
    Cells.Clear
    If r Then
        [A1].Resize(, 4) = Array("日期", "单号", "名称", "数量")
        [A2].Resize(r, 4) = vResult
    Else
        MsgBox "未找到数据"
    End If
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

参与一下。。。