完善代码请教 在线等

翁知江安

Sub test3()
    Dim brr(1 To 100, 1 To 10)
    Set d = CreateObject("scripting.dictionary")
    arr = Sheet1.Range("a1").CurrentRegion
    m = 1: n = 1
    For i = 2 To UBound(arr)
        If Not d.exists(arr(i, 2)) Then
           m = m + 1
           d(arr(i, 2)) = m
           brr(m, 1) = arr(i, 2)
        End If
        If Not d.exists(arr(i, 5)) Then
           n = n + 1
           d(arr(i, 5)) = n
           brr(1, n) = arr(i, 5)
        End If
        brr(d(arr(i, 2)), d(arr(i, 5))) = brr(d(arr(i, 2)), d(arr(i, 5))) + arr(i, 6)
    Next i
    Sheet1.Range("l2").Resize(m, n) = brr
    MsgBox "ok"
End Sub

翁知江安

供参考，欢迎批评指正

wtzxuexivba

翁知江安 发表于 2025-4-10 21:16
供参考，欢迎批评指正

看了你的附件，思路清晰，代码简洁。个人比较容易裂解，谢谢。
不知在您的代码基础上，能否实现以下蓝色区域统计功能。谢谢。

翁知江安

今天晚上试试，看看能达到这个效果

翁知江安

wtzxuexivba 发表于 2025-4-10 22:38
看了你的附件，思路清晰，代码简洁。个人比较容易裂解，谢谢。
不知在您的代码基础上，能否实现以下蓝色 ...

已初步达到设定的效果，供参考

翁知江安

Sub test3()
    Dim brr(1 To 100, 1 To 10), arr As Variant, d As Object, m, n, i As Integer
    Set d = CreateObject("scripting.dictionary")
    arr = Sheet1.Range("a1").CurrentRegion
    m = 1: n = 1
    For i = 2 To UBound(arr)
        If Not d.exists(arr(i, 2)) Then
           m = m + 1
           d(arr(i, 2)) = m
           brr(m, 1) = arr(i, 2)
        End If
        If Not d.exists(arr(i, 5)) Then
           n = n + 1
           d(arr(i, 5)) = n
           brr(1, 2 * n - 2) = arr(i, 5) & "等级出现次数"
           brr(1, 2 * n - 1) = arr(i, 5)
        End If
        brr(d(arr(i, 2)), d(arr(i, 5)) * 2 - 2) = brr(d(arr(i, 2)), d(arr(i, 5)) * 2 - 2) + 1
        brr(d(arr(i, 2)), d(arr(i, 5)) * 2 - 1) = brr(d(arr(i, 2)), d(arr(i, 5)) * 2 - 1) + arr(i, 6)
    Next i
    Sheet1.Range("l2").Resize(m, 2 * n + 1) = brr
    MsgBox "ok"
End Sub

翁知江安

这里只有WPS ，将就用吧。程序在模块2中。

wtzxuexivba

翁知江安 发表于 2025-4-11 12:48
这里只有WPS ，将就用吧。程序在模块2中。

非常感谢老师耐心、细致的解答。占用您的宝贵时间，再次向您表示感谢。