求助：添加总计合计并自动排序

张其祥

张其祥

请大神帮忙，劳驾写出VBA代码。本人尚未入门，拜托了。

liulang0808

Sub 按钮1_Click()
    Set d = CreateObject("scripting.dictionary")
    Set dd = CreateObject("scripting.dictionary")
    arr = [a1:b11]
    With CreateObject("vbscript.regexp")
        .Pattern = "[一-龥]+"
        For j = 2 To UBound(arr)
            If .test(arr(j, 1)) Then
                str1 = .Execute(arr(j, 1))(0)
                If Not d.exists(str1) Then
                    Set d(str1) = CreateObject("scripting.dictionary")
                End If
                d(str1)(Val(arr(j, 2))) = d(str1)(Val(arr(j, 2))) & "," & j
                dd(str1) = dd(str1) + Val(arr(j, 2))
            End If
        Next j
    End With
    Cells(2, 11) = WorksheetFunction.Sum(dd.items)
    r = 2
l1:
    If dd.Count <> 0 Then
        m = WorksheetFunction.Large(dd.items, 1)
        For j = dd.Count - 1 To 0 Step -1
            If dd.items()(j) = m Then
                k = dd.keys()(j)
                r = r + 1
                Cells(r, 10) = k & "合计"
                Cells(r, 11) = m
                For i = 1 To d(k).Count
                    n = WorksheetFunction.Large(d(k).keys, i)
                    brr = Split(d(k)(n), ",")
                    For Z = 1 To UBound(brr)
                        r = r + 1
                        rx = Val(brr(Z))
                        Cells(r, 10) = arr(rx, 1)
                        Cells(r, 11) = arr(rx, 2)
                        
                    Next Z
                Next i
                dd.Remove dd.keys()(j)
            End If
        Next j
        GoTo l1
    End If
End Sub

liulang0808

跟楼主模拟的结果有出入，供参考。。。。

张其祥

liulang0808 发表于 2024-3-23 06:58
跟楼主模拟的结果有出入，供参考。。。。

liulang080：

     您 好。您提供的解决方案非常完美，实现不仅地区内按金额大小按倒序排列，而且同时还对各地区合计也同时按金额大小倒序排列。非常感谢！