怎么在变动的表格中求不确定行数的和

小女孩

求助A.rar (22.4 KB, 下载次数: 3)

2018-9-5 19:29 上传

点击文件名下载附件

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("a1:b" & r)
   
7.     s = 0
   
8.     For i = UBound(arr) To 1 Step -1
   
9.       If Len(arr(i, 2)) <> 0 Then
   
10.         s = s + arr(i, 2)
    
11.       Else
    
12.         arr(i, 2) = s
    
13.         s = 0
    
14.       End If
    
15.     Next
    
16.     .Range("c1").Resize(UBound(arr), 2) = arr
    
17.   End With
    
18. End Sub
    

复制代码

chxw68

详见附件。

liulang0808

1. Sub °′&#197;￥1_Click()
   
2.     Application.ScreenUpdating = False
   
3.     arr = [a1].CurrentRegion
   
4.     sm = 0
   
5.     For j = UBound(arr) To 1 Step -1
   
6.         If Len(arr(j, 2)) = 0 Then
   
7.             arr(j, 2) = sm
   
8.             sm = 0
   
9.         Else
   
10.             sm = sm + arr(j, 2)
    
11.         End If
    
12.     Next j
    
13.     [a1].CurrentRegion = arr
    
14.     Application.ScreenUpdating = True
    
15. End Sub
    

复制代码

chxw68

1. Sub test2()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   With Worksheets("sheet1")
   
5.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
6.     arr = .Range("a1:b" & r)
   
7.     For i = 1 To UBound(arr)
   
8.       If Len(arr(i, 2)) = 0 Then
   
9.         m = i
   
10.       Else
    
11.         arr(m, 2) = arr(m, 2) + arr(i, 2)
    
12.       End If
    
13.     Next
    
14.     .Range("c1").Resize(UBound(arr), 2) = arr
    
15.   End With
    
16. End Sub
    
17. 
    

复制代码

liulang0808

附件内容供参考。。。。。。

chxw68

正序也可以。

一指禅62

1. 
   
2. Sub 一键汇总()
   
3.     Dim arr, i&, j&, key$, a(), n&, M
   
4.     arr = Sheet1.Range("A1").CurrentRegion
   
5.     j = 1
   
6.     For i = j To UBound(arr)
   
7.         If Val(arr(i, 2)) = 0 Then
   
8.             M = 0: n = n + 1
   
9.             ReDim Preserve a(1 To 2, 1 To n)
   
10.             key = arr(i, 1)
    
11.             a(1, n) = key
    
12.             j = j + i + 1
    
13.         Else
    
14.             M = M + Val(arr(i, 2))
    
15.             a(2, n) = M
    
16.         End If
    
17.     Next
    
18.     Range("J1:K1000").ClearContents
    
19.     If n > 0 Then Range("J1").Resize(n, 2) = WorksheetFunction.Transpose(a)
    
20. End Sub

复制代码

一指禅62

自己测试一下：

求助A.rar (31.92 KB, 下载次数: 10)

2018-9-5 20:12 上传

点击文件名下载附件