字典多item间计算方法

fengdiyelx

请教各位老师，小弟遇到个问题，不知如何计算，请见图和附件

目前已将姓名作为字典的key导入，然后金额1和金额2作为数组导入进了字典的item项

现在需要

1.计算后面的权重，金额2/金额1，如果是错误，即为0

2. 当金额1大于25万，用二者差值乘以权重，否则即为0

3.所有计算过程可以不resize出来，最好在后台计算，然后计算出结果

之前一直是用数据透视表和公式来做，但因为数据量是在太大，影响速度，想请问改如何做

第一步已经写了宏，后续如何操作，是在不会做了，来请教各位老师

Sub test()
  Dim r%, i%
  Dim arr, brr
  Dim d As Object
  Set d = CreateObject("scripting.dictionary")
  With Worksheets("sheet2")
    r = .Cells(.Rows.Count, 1).End(xlUp).Row
    arr = .Range("a2:c" & r)
    For i = 1 To UBound(arr)
        If Not d.exists(arr(i, 1)) Then
          ReDim brr(1 To 3)
          brr(1) = arr(i, 1)
        Else
          brr = d(arr(i, 1))
        End If
        brr(2) = brr(2) + arr(i, 2)
        brr(3) = brr(3) + arr(i, 3)
        d(arr(i, 1)) = brr
    Next
        .Range("e6").Resize(d.Count, 3) = Application.Transpose(Application.Transpose(d.items))
    End With
End Sub

liyanghu

用了双字典稍作修改，供参考

1. Sub test()
   
2. Dim r&, i&
   
3. Dim arr, brr
   
4. Dim d As Object
   
5. Set d = CreateObject("scripting.dictionary")
   
6. Set e = CreateObject("scripting.dictionary")
   
7. With Worksheets("sheet2")
   
8.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
9.     arr = .Range("a2:c" & r)
   
10.     For i = 1 To UBound(arr)
    
11.         d(arr(i, 1) & ";金额1") = d(arr(i, 1) & ";金额1") + arr(i, 2)
    
12.         d(arr(i, 1) & ";金额2") = d(arr(i, 1) & ";金额2") + arr(i, 3)
    
13.         e(arr(i, 1)) = ""
    
14.     Next
    
15.     For j = 0 To e.Count - 1
    
16.     If d(e.keys()(j) & ";金额1") <> 0 Then
    
17.         per = Val(d(e.keys()(j) & ";金额2") / d(e.keys()(j) & ";金额1"))
    
18.         If d(e.keys()(j) & ";金额1") > 250000 Then
    
19.             aSum = aSum + (d(e.keys()(j) & ";金额1") - 250000) * per
    
20.         End If
    
21.     End If
    
22.     Next
    
23.     Debug.Print Format(aSum, "0.00")
    
24. End With
    
25. Set d = Nothing
    
26. Set e = Nothing
    
27. End Sub

复制代码

tigertc

1. Sub aa()
   
2. Dim arr, d1, d2
   
3. Set d1 = CreateObject("scripting.dictionary")
   
4. Set d2 = CreateObject("scripting.dictionary")
   
5. arr = Range("a2:c" & [a1048576].End(3).Row)
   
6. For i = 1 To UBound(arr)
   
7.     d1(arr(i, 1)) = d1(arr(i, 1)) + arr(i, 2)
   
8.     d2(arr(i, 1)) = d2(arr(i, 1)) + arr(i, 3)
   
9. Next i
   
10. k = d1.keys: t1 = d1.items: t2 = d2.items
    
11. ReDim arr(1 To d1.Count, 1 To 3)
    
12. For i = 0 To UBound(k)
    
13.     arr(i + 1, 1) = k(i)
    
14.     arr(i + 1, 2) = t1(i)
    
15.     arr(i + 1, 3) = t2(i)
    
16.     If t1(i) > 250000 Then a = a + (t1(i) - 250000) * (t2(i) / t1(i))
    
17. Next i
    
18. [e5].Resize(1, 3) = Array("日期", "金额1", "金额2")
    
19. [e6].Resize(UBound(arr), 3) = arr
    
20. [i14] = a
    
21. End Sub

复制代码

清风竹-

请看附件 。