20170928xlVBA自定义分类汇总

Posted 2020-10-09

SubtotalByCQL Range("A1:E100").Value, "Select 1,2,Sum(4),Count(4) GroupBy 1,2", Range("J1"), True
Sub SubtotalByCQL(ByVal Arr As Variant, ByVal CQL As String, ByVal DesRange As Range, Optional Header As Boolean = False)
    Dim i As Long, j As Long, m As Long
    Dim Sel As String, Grp As String, Sels, Grps
    Dim Ar() As Variant, Br As Variant
    Dim Dic As Object
    Set Dic = CreateObject("Scripting.Dictionary")
    
    CQL = UCase(CQL)
    Sel = Replace(Replace(Split(CQL, "GROUPBY")(0), " ", ""), "SELECT", "")
    Sels = Split(Sel, ",")
    Grp = Replace(Split(CQL, "GROUPBY")(1), " ", "")
    Grps = Split(Grp, ",")
    
    If Header Then
        Key = ""
        For j = LBound(Grps) To UBound(Grps)
            Key = Key & ";" & Arr(1, CLng(Grps(j)))
        Next j
        Key = Mid(Key, 2)
        ReDim Ar(0 To 0)
        m = 0
        For j = LBound(Sels) To UBound(Sels)
            ReDim Preserve Ar(0 To m)
            If IsNumeric(Sels(j)) Then
                Ar(m) = Arr(1, CLng(Sels(j)))
            Else
                Select Case Split(Sels(j), "(")(0)
                Case "SUM"
                    Ar(m) = Arr(1, CLng(Split(Split(Sels(j), "(")(1), ")")(0))) & "-求和"
                Case "COUNT"
                    Ar(m) = Arr(1, CLng(Split(Split(Sels(j), "(")(1), ")")(0))) & "-计数"
                End Select
            End If
            m = m + 1
        Next j
        Dic(Key) = Ar
    End If
    
    For i = LBound(Arr) + IIf(Header, 1, 0) To UBound(Arr)
        Key = ""
        For j = LBound(Grps) To UBound(Grps)
            Key = Key & ";" & Arr(i, CLng(Grps(j)))
        Next j
        Key = Mid(Key, 2)
        If Not Dic.Exists(Key) Then
            ReDim Ar(0 To 0)
            m = 0
            For j = LBound(Sels) To UBound(Sels)
                
                ReDim Preserve Ar(0 To m)
                If IsNumeric(Sels(j)) Then
                    Ar(m) = Arr(i, CLng(Sels(j)))
                Else
                    Select Case Split(Sels(j), "(")(0)
                    Case "SUM"
                        Ar(m) = Arr(i, CLng(Split(Split(Sels(j), "(")(1), ")")(0)))
                    Case "COUNT"
                        Ar(m) = 1
                    End Select
                End If
                m = m + 1
            Next j
            Dic(Key) = Ar
        Else
            Br = Dic(Key)
            For j = LBound(Sels) To UBound(Sels)
                If IsNumeric(Sels(j)) Then
                Else
                    Select Case Split(Sels(j), "(")(0)
                    Case "SUM"
                        Br(j) = Br(j) + Arr(i, CLng(Split(Split(Sels(j), "(")(1), ")")(0)))
                    Case "COUNT"
                        Br(j) = Br(j) + 1
                    End Select
                End If
            Next j
            Dic(Key) = Br
        End If
    Next i
    DesRange.Resize(Dic.Count, UBound(Sels) + 1).Value = _
        Application.Rept(Dic.items, 1)
        Set Dic = Nothing
End Sub