20170523xlVBA多条件分类求和一例

Public Sub NextSeven_CodeFrame()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual
    Application.StatusBar = ">>>>>>>>程序正在运行>>>>>>>>"

    On Error GoTo ErrHandler

    Dim StartTime, UsedTime As Variant
    StartTime = VBA.Timer
    '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
    Dim Wb As Workbook
    Dim Sht As Worksheet
    Dim OpenWb As Workbook
    Dim OneSht As Worksheet

    Dim Arr As Variant
    Dim i As Long

    Dim FolderPath As String
    Dim FileName As String
    Dim FileCount As Long

    Dim OneKey
    Dim Key As String
    Dim Dic As Object


    Set Dic = CreateObject("Scripting.Dictionary")

    '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
    Set Wb = Application.ThisWorkbook
    Set Sht = Wb.Worksheets("分类汇总")

    FolderPath = Wb.Path & Application.PathSeparator
    FileCount = 0
    FileName = Dir(FolderPath & "*.xls*")
    Do While FileName <> ""
        If FileName <> ThisWorkbook.Name Then
            FileCount = FileCount + 1
            Set OpenWb = Application.Workbooks.Open(FolderPath & FileName)
            With OpenWb
                For Each OneSht In .Worksheets
                    If OneSht.Name Like "*月" Then
                        With OneSht
                            endrow = .Cells(.Cells.Rows.Count, "B").End(xlUp).Row
                            Set Rng = .Range("A3:F" & endrow)
                            Arr = Rng.Value
                            For i = LBound(Arr) To UBound(Arr)
                                Key = .Name & ";" & CStr(Arr(i, 2) & ";" & Arr(i, 3))
                                Dic(Key) = Dic(Key) + Arr(i, 4)
                            Next i
                        End With
                    End If
                Next OneSht
                .Close False
            End With
        End If
        FileName = Dir
    Loop


    With Sht
        .Cells.Clear
        .Range("A1:D1").Value = Array("月份", "型号与品名", "工序", "总数")
        i = 1
        For Each OneKey In Dic.Keys
            i = i + 1
            Key = CStr(OneKey)
            .Cells(i, 1).Value = Split(Key, ";")(0)
            .Cells(i, 2).Value = Split(Key, ";")(1)
            .Cells(i, 3).Value = Split(Key, ";")(2)
            .Cells(i, 4).Value = Dic(OneKey)
        Next OneKey
        SetEdges .UsedRange
    End With


    '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
    UsedTime = VBA.Timer - StartTime
    MsgBox "本次耗时：" & Format(UsedTime, "0.000秒"), vbOKOnly, "Tips"

ErrorExit:
    Set Wb = Nothing
    Set Sht = Nothing
    Set OpenWb = Nothing
    Set OneSht = Nothing
    Set Rng = Nothing


    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic
    Application.StatusBar = False
    Exit Sub
    '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
ErrHandler:
    If Err.Number <> 0 Then
        MsgBox Err.Description & "！", vbCritical, "Tips"
        'Debug.Print Err.Description
        Err.Clear
        Resume ErrorExit
    End If
End Sub