字典求合计

ykcbf1100

yshcy 发表于 2024-10-5 23:23
感谢你的多次帮助。能否写成动态的求合计及小计？这个12如果是动态的，就更完美了。

数组求和。。。

ykcbf1100

对数组求和。。。

lizhipei78

ykcbf1100 发表于 2024-10-6 09:41
对数组求和。。。

JSA在这一方面还是要方便好多，代码少好多行

ykcbf1100

lizhipei78 发表于 2024-10-6 09:54
JSA在这一方面还是要方便好多，代码少好多行

是的呢。。。

lizhipei78

ykcbf1100 发表于 2024-10-6 10:07
是的呢。。。

根据JSA的想法，反过来写一下VBA，还是可以的

ykcbf1100

lizhipei78 发表于 2024-10-6 10:23
根据JSA的想法，反过来写一下VBA，还是可以的

你牛哈。。。

Qs18

1. Sub qs()
   
2. Dim arr, i, dic
   
3. Set dic = CreateObject("scripting.dictionary")
   
4. arr = Sheet1.Range("c3").CurrentRegion.Value
   
5. ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2) + 1)
   
6. ReDim crr(1 To 1, 1 To UBound(brr, 2)): crr(1, 1) = "合计"
   
7. For i = 2 To UBound(arr)
   
8. sm = 0
   
9.     If Not dic.exists(arr(i, 1)) Then
   
10.         m = m + 1
    
11.         brr(m, 1) = arr(i, 1)
    
12.         dic(arr(i, 1)) = m
    
13.         For c = 2 To 4
    
14.             brr(m, c) = arr(i, c)
    
15.             sm = sm + arr(i, c)
    
16.         Next
    
17.         brr(m, 5) = sm
    
18.     Else
    
19.         r = dic(arr(i, 1))
    
20.         For c = 2 To 4
    
21.             brr(r, c) = brr(r, c) + arr(i, c)
    
22.             sm = sm + brr(r, c)
    
23.         Next
    
24.         brr(r, 5) = sm
    
25.     End If
    
26. Next
    
27. For cl = 2 To UBound(brr, 2)
    
28.     crr(1, cl) = Application.WorksheetFunction.Sum(Application.Index(brr, 0, cl))
    
29. Next
    
30. Sheet1.Range("h3").Resize(m, 5) = brr
    
31. Sheet1.Range("h3").Offset(m, 0).Resize(1, 5) = crr
    
32. Set dic = Nothing
    
33. End Sub
    

复制代码

Qs18

试试.......

Qs18

试试...........