字典代码的简化

周爽

请问，以下代码如何简化？先谢谢各位大神。

sub 去重多个Item求和()
Dim brr, x
Dim d1 As Object
  Set d1 = CreateObject("scripting.dictionary")  '创建字典
Dim d2 As Object
  Set d2 = CreateObject("scripting.dictionary")  '创建字典
Dim d3 As Object
  Set d3 = CreateObject("scripting.dictionary")  '创建字典
Dim d4 As Object
  Set d4 = CreateObject("scripting.dictionary")  '创建字典

     brr = Range("b4:g1000")
       For x = 1 To UBound(brr)
         d1(brr(x, 1)) = d1(brr(x, 1)) + brr(x, 3) 'key对应的item的值在原来的基础上加新的
         d2(brr(x, 1)) = d2(brr(x, 1)) + brr(x, 4)
         d3(brr(x, 1)) = d3(brr(x, 1)) + brr(x, 5)
         d4(brr(x, 1)) = d4(brr(x, 1)) + brr(x, 6)
       Next x
         SHX.Range("B4:G1048576").ClearContents
             SHX.Cells(4, 2).Resize(d1.Count) = Application.Transpose(d1.Keys)
             SHX.Cells(4, 4).Resize(d1.Count) = Application.Transpose(d1.Items)
             SHX.Cells(4, 5).Resize(d1.Count) = Application.Transpose(d2.Items)
             SHX.Cells(4, 6).Resize(d1.Count) = Application.Transpose(d3.Items)
             SHX.Cells(4, 7).Resize(d1.Count) = Application.Transpose(d4.Items)
end sub

山菊花

Sub 去重多个Item求和()
    Dim brr, x, Arr()
    Dim ds As Object, m%, n%
    Set ds = CreateObject("scripting.dictionary")  '创建字典
    brr = Range("b4:g1000")
    ReDim Arr(1 To UBound(brr), 1 To 6)
    For x = 1 To UBound(brr)
        n = ds(brr(x, 1))
        If n = 0 Then
            m = m + 1
            Arr(m, 1) = brr(x, 1)
            n = m
            ds(Arr(m, 1)) = n
        End If
        For j = 3 To 6
            Arr(n, j) = Arr(n, j - 1) + brr(x, j)
        Next
    Next x
    With shx
        n = .Range("B1048576").End(xlUp).Row
        .Range("B4:G" & n).ClearContents
        .Range("b4").Resize(m, 6).Value = Arr
    End With
End Sub

liulang0808

Sub 去重多个Item求和()
Dim brr, x
Dim ARR()
Dim CRR
  Set d = CreateObject("scripting.dictionary")  '创建字典
     brr = Range("b4:g1000")
       For x = 1 To UBound(brr)
         If d.existS(brr(x, 1)) Then

            CRR = d(brr(x, 1))
            For I = 1 To UBound(CRR)
                CRR(I) = CRR(I) + brr(x, I + 2)
            Next I
            d(brr(x, 1)) = CRR
         Else
            ReDim ARR(1 To 4)
            For I = 1 To 4
                ARR(I) = ARR(I) + brr(x, I + 2)
            Next I
            d(brr(x, 1)) = ARR
         End If

       Next x
        SHX.Range("B4:G1048576").ClearContents
        SHX.Cells(4, 2).Resize(d.Count) = WorksheetFunction.Transpose(d.Keys)
        SHX.Cells(4, 4).Resize(d.Count, 4) = WorksheetFunction.Transpose(WorksheetFunction.Transpose(d.items))   '
End Sub

周爽

liulang0808 发表于 2020-2-8 21:24
Sub 去重多个Item求和()
Dim brr, x
Dim ARR()

表格是这样的，经过计算，好像有点问题

周爽

表格图片上传

周爽

山菊花 发表于 2020-2-8 21:18
Sub 去重多个Item求和()
    Dim brr, x, Arr()
    Dim ds As Object, m%, n%

表格 已上传图片格式，可能是数字对应的问题，不能得到正确结果，麻烦修改一下，谢谢

liulang0808

周爽 发表于 2020-2-8 22:45
表格是这样的，经过计算，好像有点问题

建议楼主上传附件

周爽

附件已上传

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   With Worksheets("sheet1")
   
7.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.     arr = .Range("a4:h" & r)
   
9.   End With
   
10.   For i = 1 To UBound(arr)
    
11.     If Len(arr(i, 2)) <> 0 Then
    
12.       If Not d.exists(arr(i, 2)) Then
    
13.         ReDim brr(1 To UBound(arr, 2))
    
14.         brr(2) = arr(i, 2)
    
15.       Else
    
16.         brr = d(arr(i, 2))
    
17.       End If
    
18.       For j = 4 To 7
    
19.         brr(j) = brr(j) + arr(i, j)
    
20.       Next
    
21.       d(arr(i, 2)) = brr
    
22.     End If
    
23.   Next
    
24.   With Worksheets("sheet2")
    
25.     .UsedRange.Offset(3, 0).Clear
    
26.     brr = Application.Transpose(Application.Transpose(d.items))
    
27.     For i = 1 To UBound(brr)
    
28.       brr(i, 1) = i
    
29.       For j = 4 To 7
    
30.         brr(i, 3) = brr(i, 3) + brr(i, j)
    
31.       Next
    
32.     Next
    
33.     .Range("a4").Resize(UBound(brr), UBound(brr, 2)) = brr
    
34.     r = 3 + UBound(brr) + 1
    
35.     .Cells(r, 2) = "合计"
    
36.     .Cells(r, 3).Resize(1, 5).FormulaR1C1 = "=SUM(R4C:R[-1]C)"
    
37.    
    
38.   End With
    
39.    
    
40. End Sub
    

复制代码

chxw68

详见附件。