[已解决]用VBA数组字典进行多条件求和

laoau138

用VBA数组字典进行多条件求和

最佳答案

月排行榜 / 总排行榜

idnoidno

2017-6-19 20:55

1. Sub test()
   
2.     Dim dic As Object
   
3.     Dim v
   
4.     Dim i As Long, s
   
5.      
   
6.     Set dic = CreateObject("scripting.dictionary")
   
7.      
   
8.     v = Range("a1").CurrentRegion.Value
   
9.     For i = 2 To UBound(v)
   
10.         s = v(i, 1) & vbTab & v(i, 2)
    
11.         If Not dic.Exists(s) Then dic(s) = Array(, , 0, 0)
    
12.         dic(s) = Array(v(i, 1), v(i, 2), dic(s)(2) + 1, dic(s)(3) + v(i, 3))
    
13.     Next
    
14.      
    
15.     With Range("F1")
    
16.         .CurrentRegion.ClearContents
    
17.         .Resize(, 4).Value = [{"產品","規格","次數","總和"}]
    
18.         .Offset(1).Resize(dic.Count, 4).Value = _
    
19.         Application.Transpose(Application.Transpose(dic.Items))
    
20.         .CurrentRegion.Sort key1:=.Columns(1), Header:=xlYes
    
21.     End With
    
22.      
    
23. End Sub
    
24. 
    
25. 
    

复制代码

跳转到最佳答案楼层

idnoidno

1. Sub test()
   
2.     Dim dic As Object
   
3.     Dim v
   
4.     Dim i As Long, s
   
5.      
   
6.     Set dic = CreateObject("scripting.dictionary")
   
7.      
   
8.     v = Range("a1").CurrentRegion.Value
   
9.     For i = 2 To UBound(v)
   
10.         s = v(i, 1) & vbTab & v(i, 2)
    
11.         If Not dic.Exists(s) Then dic(s) = Array(, , 0, 0)
    
12.         dic(s) = Array(v(i, 1), v(i, 2), dic(s)(2) + 1, dic(s)(3) + v(i, 3))
    
13.     Next
    
14.      
    
15.     With Range("F1")
    
16.         .CurrentRegion.ClearContents
    
17.         .Resize(, 4).Value = [{"產品","規格","次數","總和"}]
    
18.         .Offset(1).Resize(dic.Count, 4).Value = _
    
19.         Application.Transpose(Application.Transpose(dic.Items))
    
20.         .CurrentRegion.Sort key1:=.Columns(1), Header:=xlYes
    
21.     End With
    
22.      
    
23. End Sub
    
24. 
    
25. 
    

复制代码

laoau138

idnoidno 发表于 2017-6-19 20:55

这个还能优化不

idnoidno

您指的優化是什麼

idnoidno

問題沒解決嗎

laoau138

idnoidno 发表于 2017-6-20 12:53
問題沒解決嗎

你写的代码不行，怎么H列多出个次数    怎么会出现繁体字


Sub  你看这个写()
    arr = [a1].CurrentRegion
    Set d = CreateObject("scripting.dictionary")
    k = 1
    For i = 2 To UBound(arr)
        t = arr(i, 1) & arr(i, 2)
        If Not d.exists(t) Then
            k = k + 1
            d(t) = k
            If k <> i Then
                arr(k, 1) = arr(i, 1)
                arr(k, 2) = arr(i, 2)
                arr(k, 3) = arr(i, 3)
            End If
        Else
            arr(d(t), 3) = arr(d(t), 3) + arr(i, 3)
        End If
    Next
    [f1].Resize(k, 3) = arr
End Sub

idnoidno

統計次數你不要嗎，我是台灣人，為了學習所以加入這邊來跟大家一起學習

laoau138

idnoidno 发表于 2017-6-20 16:56
統計次數你不要嗎，我是台灣人，為了學習所以加入這邊來跟大家一起學習

论坛好厉害，台湾人也进来了，你说"什么语"    难道说“普通话”

laoau138

idnoidno 发表于 2017-6-20 16:56
統計次數你不要嗎，我是台灣人，為了學習所以加入這邊來跟大家一起學習

遥远的他方，更要顶你了

laoau138

idnoidno 发表于 2017-6-19 20:55

你的VBA，自学，还是跟某个师傅