Excel累積が規定数を超えたらまたゼロから累積

質問

マクロに関してご相談です。

Ａ列に数値が入っています。1000行ほどあります。
それらの数値を上から順にA1＋A2＋…と加算していき，500以上になったらその行のＢ列にその合計を記入し，一旦ゼロにリセットし次のＡ列の行（添付の図ではA6）からまた加算を始め，500になったらその行のＢ列に合計を記入し…ということを，Ａ列の数値が終わるまで繰り返す，という作業を行いたいと思います。

以前他の方の質問で下記の回答が掲載されていました。

VBAでの一例です。
データは1行目からあるとします。

Sub Sample1()
Dim i As Long, myVal1, myVal2
Range("B:B").ClearContents
For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row
myVal1 = myVal1 + Cells(i, "A")
myVal2 = myVal1 + Cells(i + 1, "A")
If myVal1 <= 500 And myVal2 > 500 Then
If 500 - myVal1 <= myVal2 - 500 Then
Cells(i, "B") = myVal1
Else
Cells(i + 1, "B") = myVal2
i = i + 1
End If
myVal1 = 0
End If
Next i
End Sub

この方の質問の場合、合計数がちょうど500になることはまれなので，近似のセルをとるようにするという条件がありました。
今回はこの近似の条件は不要で500を超えたら、ゼロから累積するようにしたいですが、マクロをどのように修正したらよいでしょうか。

何かしらのヒントでもいただければと存じます。
よろしくお願いいたします。

回答No.1

kkkkkm · ベストアンサー

myVal2がいりませんからそれに関するところを除いて

500以上の条件式は
myVal1 >= 500

で修正してみてください。

回答No.2

imogasi

こんなのでよいのかな。B列結果をみて、打ち切るタイミングが、違っておれば言ってください。
標準モジュールに
Sub test01()
frm = 2
lr = Range("A100000").End(xlUp).Row
For i = 2 To lr
If WorksheetFunction.Sum(Range("A" & frm & ":a" & i)) < 500 Then
Cells(i, "B") = WorksheetFunction.Sum(Range("A" & frm & ":a" & i))
Else
frm = i
Cells(i, "B") = WorksheetFunction.Sum(Range("A" & frm & ":a" & i))
End If
Next i
End Sub
＝＝＝
データ例と結果　A2:B11
123 123
324 447
212 212
111 323
123 446
324 324
212 212
111 323
111 434
65 499