特别求和

wowo000

各位老师：早上好！劳烦哪位帮俺用VBA代码实现附件里截图效果，谢谢！

ynzsvt

1. Sub 累加到第一行()
   
2. Dim Arr, i&, j&, k&, L&, Dic As Object, Brr, Crr, Drr, Frr, r&
   
3. Set Dic = CreateObject("Scripting.Dictionary")
   
4. 
   
5. r = Cells(Rows.Count, "B").End(xlUp).Row - 1
   
6. Arr = [B2].Resize(r)
   
7. Brr = [K2].Resize(r)
   
8. Crr = [N2].Resize(r)
   
9. ReDim Drr(1 To r, 0)
   
10. ReDim Frr(1 To r, 0)
    
11. 
    
12. For i = 1 To r
    
13.   If Dic.Exists(Arr(i, 1)) Then j = Dic(Arr(i, 1)) Else Dic(Arr(i, 1)) = i: j = i
    
14.   Drr(j, 0) = Drr(j, 0) + Brr(i, 1)
    
15.   Frr(j, 0) = Frr(j, 0) + Crr(i, 1)
    
16. Next
    
17. 
    
18. [L2].Resize(r) = Drr
    
19. [M2].Resize(r) = Frr
    
20. Set Dic = Nothing
    
21. End Sub

复制代码

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     With Worksheets("sheet1")
   
5.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
6.         arr = .Range("f2:n" & r)
   
7.         s1 = 0
   
8.         s2 = 0
   
9.         For i = UBound(arr) To 1 Step -1
   
10.             If Len(arr(i, 1)) = 0 Then
    
11.                 arr(i, 7) = arr(i, 6)
    
12.                 arr(i, 8) = arr(i, 9)
    
13.             Else
    
14.                 s1 = s1 + arr(i, 6)
    
15.                 s2 = s2 + arr(i, 9)
    
16.                 If arr(i, 1) = "母" Then
    
17.                     arr(i, 7) = s1
    
18.                     arr(i, 8) = s2
    
19.                     s1 = 0
    
20.                     s2 = 0
    
21.                 End If
    
22.             End If
    
23.         Next
    
24.         .Range("f2:n" & r) = arr
    
25.     End With
    
26.                     
    
27. End Sub
    

复制代码

chxw68

非常简单的问题。

wowo000

chxw68 发表于 2024-9-15 07:58
非常简单的问题。

尊敬的chxw68老师：衷心感谢您一大早的回复，谢谢！