Excel·VBA统计多部门多商品销售量前10%的商品

如图：根据表中唯一的货品ID，有m个事业部中分别有n种货品，统计各事业部销量前10%的货品名称，生成统计表（以下为2种统计方式）

仅统计货品ID

方法1：字典嵌套字典

以事业部名称为1级键，货品ID为2级键，销量为值，统计销量前10%（向上取整）
以下代码使用了二维数组排序，调用了bubble_sort_arr函数，代码详见《Excel·VBA数组冒泡排序函数》（如需使用代码需复制）

Sub 销售数据筛选1()
    Dim dict As Object, arr, res, temp, i&, j&, x&, y&, k, kk, m&, n&
    Set dict = CreateObject("scripting.dictionary"): tm = Timer
    With Worksheets("Sheet1")  '读取数据
        arr = .[a1].CurrentRegion
        For i = 2 To UBound(arr)
            If Not dict.Exists(arr(i, 6)) Then
                Set dict(arr(i, 6)) = CreateObject("scripting.dictionary")
            End If
            dict(arr(i, 6))(arr(i, 1)) = dict(arr(i, 6))(arr(i, 1)) + arr(i, 7)
        Next
    End With
    With Worksheets("Sheet2")  '写入结果
        ReDim res(1 To dict.Count, 0 To 100)
        For Each k In dict.keys
            x = x + 1: res(x, 0) = k  '事业部
            m = dict(k).Count: n = WorksheetFunction.RoundUp(m * 0.1, 0)  '前10%
            If n > UBound(res, 2) Then ReDim Preserve res(1 To UBound(res), 0 To n)
            y = 0: ReDim temp(1 To dict(k).Count, 1 To 2)
            For Each kk In dict(k).keys
                y = y + 1: temp(y, 1) = kk: temp(y, 2) = dict(k)(kk)
            Next
            y = 0: temp = bubble_sort_arr(temp, 2, "-")  '数组排序
            For j = 1 To n
                y = y + 1: res(x, y) = temp(j, 1)  '货品ID
            Next
        Next
        .[a1].Resize(UBound(res), UBound(res, 2) + 1) = res
    End With
    Debug.Print "用时：" & Format(Timer - tm, "0.00")  '耗时
End Sub

结果

部分截图

方法2：自定义函数

之前写过的《Excel·VBA统计表生成函数及应用实例》对数据的2个条件汇总生成一个二维横纵统计表
该函数与本问题类似，可以先对原始数据进行整理，再使用该函数生成一个二维数组，然后遍历数组、排序、写入（如需使用代码需复制）

Sub 销售数据筛选2()
    Dim arr, brr, res, i&, j&, x&, n&
    tm = Timer
    With Worksheets("Sheet1")
        arr = .[a1].CurrentRegion.Offset(1).Value
        brr = COLLECT(arr, 6, 1, 7)  '调用函数获取返回数组
    End With
    With Worksheets("Sheet3")  '写入结果
        ReDim res(1 To UBound(brr), 0 To UBound(brr, 2))
        For i = 1 To UBound(brr)
            x = 0: res(i, 0) = brr(i, 0)  '事业部
            ReDim temp(1 To UBound(brr, 2), 1 To 2)
            For j = 1 To UBound(brr, 2)
                If Len(brr(i, j)) Then x = x + 1: temp(x, 1) = brr(0, j): temp(x, 2) = brr(i, j)
            Next
            If i = UBound(brr) Then Debug.Print x, temp(x, 1), temp(1, 2)
            n = WorksheetFunction.RoundUp(x * 0.1, 0)  '前10%
            temp = bubble_sort_arr(temp, 2, "-")  '数组排序
            For j = 1 To n
                res(i, j) = temp(j, 1)  '货品ID
            Next
        Next
        .[a1].Resize(UBound(res), UBound(res, 2) + 1) = res
    End With
    Debug.Print "用时：" & Format(Timer - tm, "0.00")  '耗时
End Sub

结果

生成结果与 方法1 基本一致，除了有1个事业部仅1种商品，切销量为负数，未能生成结果；同时代码运行速度也较 方法1 慢了几倍

筛选保留整行数据

采用《Excel·VBA按列拆分工作表、工作簿》先Union行再删除的方法，将非销量前10%的整行删除

Sub 销售数据筛选3()
    Dim dict As Object, dict2 As Object, arr, temp, i&, j&, y&, m&, n&, rng As Range
    Set dict = CreateObject("scripting.dictionary"): tm = Timer
    Set dict2 = CreateObject("scripting.dictionary")
    With Worksheets("Sheet1")
        arr = .[a1].CurrentRegion
        For i = 2 To UBound(arr)
            s = arr(i, 6) & arr(i, 1)
            If Not dict.Exists(arr(i, 6)) Then
                Set dict(arr(i, 6)) = CreateObject("scripting.dictionary")
            End If
            dict(arr(i, 6))(arr(i, 1)) = dict(arr(i, 6))(arr(i, 1)) + arr(i, 7)
            dict2(s) = dict2(s) & "," & i    '行号
        Next
        For Each k In dict.keys
            m = dict(k).Count: n = WorksheetFunction.RoundUp(m * 0.1, 0)  '前10%
            y = 0: ReDim temp(1 To m, 1 To 2)
            For Each kk In dict(k).keys
                y = y + 1: temp(y, 1) = dict2(k & kk): temp(y, 2) = dict(k)(kk)
            Next
            temp = bubble_sort_arr(temp, 2, "-")  '数组排序
            For j = 1 To n
                keep = keep & "," & temp(j, 1)  '不删除行号
            Next
        Next
        .Copy after:=Worksheets(Worksheets.Count)  '复制到最后
        With ActiveSheet
            .Name = "筛选结果": crr = Split(keep, ",")
            For i = 2 To UBound(arr)
                c = Application.Match(CStr(i), crr, 0)
                If TypeName(c) = "Error" Then
                    If rng Is Nothing Then
                        Set rng = .Rows(i)
                    Else
                        Set rng = Union(rng, .Rows(i))
                    End If
                End If
            Next
            If Not rng Is Nothing Then rng.Delete
        End With
    End With
    Debug.Print "用时：" & Format(Timer - tm, "0.00")  '耗时
End Sub

结果

部分截图