20170711xlVBA自定义分类汇总一例

Public Sub CustomSubTotal()
    AppSettings
    On Error GoTo ErrHandler
    Dim StartTime, UsedTime As Variant
    StartTime = VBA.Timer
    'Input code here

    Dim i As Long, j As Long, k
    Dim Wb As Workbook
    Dim Sht As Worksheet
    Dim oSht As Worksheet
    Dim Dic As Object
    Dim Arr As Variant
    Dim Rng As Range
    Set Dic = CreateObject("Scripting.Dictionary")
    Dim SendDate$, Client$, Cargo$, Style$, Num#

    Set Wb = Application.ThisWorkbook
    Set Sht = Wb.Worksheets("数据表")
    Set oSht = Wb.Worksheets("统计表")
    With Sht
        endrow = .Cells.Find("*", .Cells(1, 1), xlValues, xlWhole, xlByRows, xlPrevious).Row
        Set Rng = .Range("A2:Z" & endrow)
        Arr = Rng.Value
        For i = LBound(Arr) To UBound(Arr)
            SendDate = Format(CStr(Arr(i, 2)), "yyyy年mm月")
            'Debug.Print mydate
            Client = Arr(i, 4)
            If Client = "" Then Client = "空"
            Cargo = Arr(i, 5)
            If Cargo = "" Then Cargo = "空"
            Num = Arr(i, 10)
            If InStr(1, Arr(i, 8), "，") > 0 Then
                Style = Split(Arr(i, 8), "，")(0)
            Else
                Style = Arr(i, 8)
            End If
            'Debug.Print Style

            Key = SendDate & ";" & Client & ";" & Cargo & ";" & Style
            Dic(Key) = Dic(Key) + Num

        Next i

    End With

    With oSht
        .Cells.Clear
        .Range("A1:E1").Value = Array("月份", "客户", "货品", "花色", "数量")
        Arr = SubTotalDicToArr(Dic, ";")
        .Range("A2").Resize(UBound(Arr), UBound(Arr, 2)).Value = Arr

        CustomSort .Range("A1").CurrentRegion
        SetEdges .Range("A1").CurrentRegion

    End With

    UsedTime = VBA.Timer - StartTime
    Debug.Print "UsedTime：" & Format(UsedTime, "0.000 Seconds")

ErrorExit:
    AppSettings False

    Set Wb = Nothing
    Set Sht = Nothing
    Set oSht = Nothing
    Set Rng = Nothing
    Set Dic = Nothing

    Exit Sub
ErrHandler:
    If Err.Number <> 0 Then
        MsgBox Err.Description & "！", vbCritical, "NextSeven QQ 84857038"
        Debug.Print Err.Description
        Err.Clear
        Resume ErrorExit
    End If
End Sub
Public Sub AppSettings(Optional IsStart As Boolean = True)
    If IsStart Then
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False
        Application.Calculation = xlCalculationManual
        Application.StatusBar = ">>>>>>>>Macro Is Running>>>>>>>>"
    Else
        Application.ScreenUpdating = True
        Application.DisplayAlerts = True
        Application.Calculation = xlCalculationAutomatic
        Application.StatusBar = False
    End If
End Sub
Public Function SubTotalDicToArr(ByVal Dic As Object, ByVal Separator As String) As Variant()
    Dim Arr(), OneKey, Key$, Item$, iRow&, iCol&
    Dim Keys, Items, m&, n&, KeyCount&, ItemCount&
    iCol = 0
    For Each OneKey In Dic.Keys
        iCol = UBound(Split(OneKey, Separator)) + 1
        iCol = iCol + UBound(Split(Dic(OneKey), Separator)) + 1
        Exit For
    Next OneKey
    iRow = Dic.Count
    ReDim Arr(1 To iRow, 1 To iCol)
    m = 0
    For Each OneKey In Dic.Keys
        m = m + 1
        Keys = Split(OneKey, Separator)
        KeyCount = UBound(Keys) + 1
        For n = 1 To KeyCount
            Arr(m, n) = Keys(n - 1)
        Next n
        Items = Split(Dic(OneKey), Separator)
        ItemCount = UBound(Items) + 1
        For n = 1 To ItemCount
            Arr(m, KeyCount + n) = Items(n - 1)
        Next n
    Next OneKey
    SubTotalDicToArr = Arr
End Function

Private Sub SetEdges(ByVal Rng As Range)
    With Rng
      .HorizontalAlignment = xlCenter
        With .Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        With .Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        With .Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        If .Cells.Count > 1 Then
            With .Borders(xlInsideVertical)
                .LineStyle = xlContinuous
                .Weight = xlThin
                .ColorIndex = xlAutomatic
            End With
            With .Borders(xlInsideHorizontal)
                .LineStyle = xlContinuous
                .Weight = xlThin
                .ColorIndex = xlAutomatic
            End With
        End If
    End With
End Sub
Sub CustomSort(ByVal RngWithTitle As Range)
    With RngWithTitle
        .Sort Key1:=RngWithTitle.Cells(1, 1), Order1:=xlAscending, _
        Key2:=RngWithTitle.Cells(1, 2), Order2:=xlAscending, Header:=xlYes, _
        MatchCase:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin
    End With
End Sub