请教各位老师，关于分段汇总的问题

fzxba

1. Sub test1()
   
2.   Dim ar, i As Long, p As Long
   
3.   ar = Range("A3", Cells(Rows.Count, "I").End(xlUp).Offset(, 1))
   
4.   For i = 1 To UBound(ar)
   
5.     If Len(ar(i, 1)) * Len(ar(i, 3)) = 0 Then
   
6.       If ar(i, 10) <> "不计" Then ar(p, 9) = ar(p, 9) + ar(i, 9)
   
7.     Else
   
8.       p = i
   
9.       ar(p, 9) = 0
   
10.     End If
    
11.   Next
    
12.   Range("I3").Resize(UBound(ar), 1) = WorksheetFunction.Index(ar, 0, 9)
    
13. End Sub

复制代码

jdzhqddzh0804

tennicse 发表于 2022-11-28 10:57
对啊，第二个数据，表中第7行，A列是2，C列是挖沟土方，I列为啥没圈红框？

那个是截图漏了

清风竹-

Sub 总量分段计算()
Dim a, b, b2, i%, m, h
m = Range("i" & Rows.Count).End(3).Row
a = Range("c3:c" & m)
b = Range("i3:i" & m)
b2 = Range("j3:j" & m)
For i = UBound(a) To 1 Step -1
    If a(i, 1) <> "" Then
       b(i, 1) = h
       h = 0
       Else
        If b2(i, 1) = "" Then h = h + b(i, 1)
    End If
Next
Range("i3:i" & m) = b
End Sub

蓝桥玄霜

汇总的例子：

tennicse

jdzhqddzh0804 发表于 2022-11-28 11:08
那个是截图漏了

原表复制另一个改名为“测试”，以下代码测试通过

Sub test()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("测试")
   
    Dim i As Integer
    Dim j As Integer
    Dim total As Single

    Dim bExit As Boolean
   
    bExit = False
   
    i = 3
    j = 3
    With ws
        Do
            If .Cells(i, 1).Value <> "" And .Cells(i, 3).Value <> "" Then
                total = 0
                j = i + 1
                Do While .Cells(j, 1).Value = "" And .Cells(j, 3).Value = "" And .Cells(j, 9).Value <> ""
                    If .Cells(j, 10).Value <> "不计" Then total = total + .Cells(j, 9).Value
                    j = j + 1
                    If .Cells(j, 1).Value = "" And .Cells(j, 3).Value = "" And .Cells(j, 9).Value = "" Then bExit = True
                Loop

            Else
                MsgBox "出现A、C不同是有值的情况，请检查"
                Exit Do
            End If
            .Cells(i, 9).Value = "@" & total  '测试用。实际把这个@去掉
            i = j
        Loop While Not bExit
    End With
End Sub

jdzhqddzh0804

清风竹- 发表于 2022-11-28 11:16
Sub 总量分段计算()
Dim a, b, b2, i%, m, h
m = Range("i" & Rows.Count).End(3).Row

谢谢老师，模块单独运行可以汇总，唯一不足的就是不更实时更新计算。

jdzhqddzh0804

fzxba 发表于 2022-11-28 11:07

谢谢，模块单独运行可以汇总，唯一不足的就是不能实时更新计算。

jdzhqddzh0804

tennicse 发表于 2022-11-28 11:38
原表复制另一个改名为“测试”，以下代码测试通过

Sub test()

谢谢老师，模块单独运行可以汇总，但是如果计算式中存在有空行的情况，就不能汇总了。

jdzhqddzh0804

蓝桥玄霜 发表于 2022-11-28 11:34
汇总的例子：

谢谢老师，你的这个代码用不了

tanglf188

jdzhqddzh0804 发表于 2022-11-28 22:49
谢谢，模块单独运行可以汇总，唯一不足的就是不能实时更新计算。

换个地方就可以了