关于字典法合并汇总求助？

zengsijun

关于字典法合并汇总求助？



真心求助：我这里有一个这样的材料明细表，需要分别实现上面两个结果，估计得用到字典法合并汇总，但我一直弄不出来，麻烦哪位大侠帮下忙，谢谢了！

shiruiqiang

你是要有2个结果，还是一步到位，出来第二个结果？
需要字典嵌套或双字典。
里面有代码，让ykcbf老师来吧

zengsijun

shiruiqiang 发表于 2024-5-25 08:03
你是要有2个结果，还是一步到位，出来第二个结果？
需要字典嵌套或双字典。
里面有代码，让ykcbf老师来吧 ...

求两个宏代码，一个是求助01,一个是求助02,谢谢了!

3190496160

Sub 分类汇总()
Application.ScreenUpdating = False
Dim ar As Variant
Dim d As Object, dc As Object
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
Set dic = CreateObject("scripting.dictionary")
Dim br(), cr()
With ActiveSheet
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    If r < 3 Then MsgBox "数据源为空！": End
    ar = .Range("a2:f" & r)
    ReDim br(1 To UBound(ar), 1 To 7)
    ReDim cr(1 To UBound(ar), 1 To 4)
    For i = 2 To UBound(ar)
        If ar(i, 1) <> "" Then
            zd = ar(i, 2) & "|" & ar(i, 3) & "|" & ar(i, 4)
            If Not d.exists(zd) Then Set d(zd) = CreateObject("scripting.dictionary")
            d(zd)(ar(i, 6)) = d(zd)(ar(i, 6)) + 1
            zf = ar(i, 2) & "|" & ar(i, 3)
            If Not dc.exists(zf) Then Set dc(zf) = CreateObject("scripting.dictionary")
            dc(zf)(ar(i, 4)) = dc(zf)(ar(i, 4)) + ar(i, 6)
        End If
    Next i
    For Each k In d.keys
        dic.RemoveAll
        n = n + 1
        For i = 2 To UBound(ar)
            zd = ar(i, 2) & "|" & ar(i, 3) & "|" & ar(i, 4)
            If zd = k Then
                For j = 2 To 4
                    br(n, j - 1) = ar(i, j)
                Next j
                br(n, 4) = br(n, 4) + ar(i, 6)
                br(n, 5) = br(n, 5) + Val(ar(i, 4)) * ar(i, 6)
                sl = d(k)(ar(i, 6))
                w = ar(i, 6) & "*" & sl
                If Not dic.exists(w) Then
                    If br(n, 6) = "" Then
                        br(n, 6) = w
                    Else
                        br(n, 6) = br(n, 6) & "+" & w
                    End If
                    br(n, 7) = "(" & br(n, 6) & "*)" & ar(i, 4)
                    dic(w) = ""
                End If
            End If
        Next i
    Next k
    .[i1].CurrentRegion.Offset(2) = Empty
    .[i3].Resize(n, UBound(br, 2)) = br
    For Each k In dc.keys
        dic.RemoveAll
        m = m + 1
        For i = 2 To UBound(ar)
            zd = ar(i, 2) & "|" & ar(i, 3)
            If zd = k Then
                For j = 2 To 3
                    cr(m, j - 1) = ar(i, j)
                Next j
                cr(m, 3) = cr(m, 3) + Val(ar(i, 4)) * ar(i, 6)
                sl = dc(k)(ar(i, 4))
                w = ar(i, 4) & "-" & sl & "根"
                If Not dic.exists(w) Then
                    If cr(m, 4) = "" Then
                        cr(m, 4) = w
                    Else
                        cr(m, 4) = cr(m, 4) & "," & w
                    End If
                    dic(w) = ""
                End If
            End If
        Next i
    Next k
     .[q1].CurrentRegion.Offset(2) = Empty
    .[q3].Resize(m, UBound(cr, 2)) = cr
End With
Set d = Nothing
Set dc = Nothing
Set dic = Nothing
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

字典法分类汇总计数备注求助？.rar (23.05 KB, 下载次数: 24)

2024-5-25 08:30 上传

点击文件名下载附件

zengsijun

3190496160 发表于 2024-5-25 08:30

谢谢您了，非常好用，请问要分成两个独立的代码，要怎么修改呢？谢谢了！

shiruiqiang

第一个代码及效果如图

liulang0808

Sub 按钮1_Click()
    arr = [a2].CurrentRegion
    Set d = CreateObject("scripting.dictionary")
    Set dd = CreateObject("scripting.dictionary")
    For j = 2 To UBound(arr)
        k = CDate(arr(j, 2)) & arr(j, 3) & arr(j, 4)
        If Not d.exists(k) Then
            Set d(k) = CreateObject("scripting.dictionary")
        End If
        d(k)(j) = j
    Next j
    ReDim brr(1 To d.Count, 1 To 7)
    r = 0
    For Each k In d.keys
        r = r + 1
        x = d(k).keys()(0)
        brr(r, 1) = arr(x, 2)
        brr(r, 2) = arr(x, 3)
        brr(r, 3) = arr(x, 4)
        dd.RemoveAll
        For Each kk In d(k).keys
            brr(r, 4) = Val(brr(r, 4)) + Val(arr(kk, 6))
            brr(r, 5) = Val(brr(r, 5)) + Val(arr(kk, 6)) * Val(arr(kk, 4))
            dd(arr(kk, 6)) = dd(arr(kk, 6)) + 1
        Next kk
        str1 = ""
        For Each kk In dd.keys
            str1 = str1 & "+" & kk & "*" & dd(kk)
        Next kk
        brr(r, 6) = Mid(str1, 2)
        brr(r, 7) = "(" & Mid(str1, 2) & ")*" & arr(x, 4)
    Next k
    [i8].Resize(r, 7) = brr
End Sub

liulang0808

另外一个雷同，供参考

zengsijun

liulang0808 发表于 2024-5-25 08:52
Sub 按钮1_Click()
    arr = [a2].CurrentRegion
    Set d = CreateObject("scripting.dictionary")

您好，能否帮我再写完另外一个代码呢，我试着修改了一下，没有成功，麻烦您了！