请教下带合并单元格的求和问题

zxsea_7426

阿黑123456

cjc209 发表于 2023-2-8 22:32
就这么简单 就是找合并单元的第一个值相加就行了

不对，计算结果不太对

阿黑123456

zxsea_7426 发表于 2023-2-9 00:05

这个试了下也不对…

zpy2

阿黑123456 发表于 2023-2-9 08:52
这个试了下也不对…

是不是没理解你的意思啊

阿黑123456

zpy2 发表于 2023-2-9 10:36
是不是没理解你的意思啊

应该是的

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim d As Object
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     Set d1 = CreateObject("scripting.dictionary")
   
7.     p = 0
   
8.     With Worksheets("sheet1")
   
9.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
10.         arr = .Range("a1:c" & r)
    
11.         For i = 2 To UBound(arr)
    
12.             If .Cells(i, 3).MergeArea.Cells(1, 1).Address = .Cells(i, 3).Address Then
    
13.                 p = p + 1
    
14.                 hs = .Cells(i, 3).MergeArea.Rows.Count
    
15.                 For k = 1 To hs
    
16.                     d(arr(i + k - 1, 1)) = Array(arr(i + k - 1, 2), arr(i, 3), p, hs)
    
17.                 Next
    
18.             End If
    
19.         Next
    
20.         r = .Cells(.Rows.Count, 6).End(xlUp).Row
    
21.         arr = .Range("f2:f" & r)
    
22.         s = 0
    
23.         For i = 1 To UBound(arr)
    
24.             If d.exists(arr(i, 1)) Then
    
25.                 brr = d(arr(i, 1))
    
26.                 s = s + brr(0)
    
27.                 If brr(3) = 1 Then
    
28.                     s = s + brr(1)
    
29.                 Else
    
30.                     If Not d1.exists(brr(2)) Then
    
31.                         Set d1(brr(2)) = CreateObject("scripting.dictionary")
    
32.                     End If
    
33.                     d1(brr(2))(arr(i, 1)) = d1(brr(2))(arr(i, 1)) + 1
    
34.                 End If
    
35.             End If
    
36.         Next
    
37.         For Each aa In d1.keys
    
38.             x = Application.Max(d1(aa).items)
    
39.             brr = d(d1(aa).keys()(0))
    
40.             s = s + x * brr(1)
    
41.         Next
    
42.         .Range("g2") = s
    
43.     End With
    
44. End Sub
    

复制代码

chxw68

详见附件。

阿黑123456

chxw68 发表于 2023-2-9 11:59
详见附件。

这个对了
有个小问题，只选一个项目的时候会报错。

chxw68

修改好了。

阿黑123456

chxw68 发表于 2023-2-9 14:44
修改好了。

一个项目也不选的的时候还是会报错