EXCELマクロを使い、空白行ではさまれた範囲の数字を合計

質問

下記のようなデータがあります。
条件
並び方：コード順
行数：変動する
見出し行の下とコードが変わる毎に空白行が1行あります。
マクロで空白行にコード毎の計と最後に合計を入れる方法を教えてください。

元データ
コード 金額
1 10
1 20
1 50

2 40
2 20
2 30

3 50
3 10

マクロ実行結果
コード 金額
1 10
1 20
1 50
計 80
2 40
2 20
2 30
計 90
3 50
3 10
計 60
合計 230

回答No.2

noname#35109 · ベストアンサー

コード が A1 セルから下向きに並び，
金額 が B1 セルから下向きに並んでいるとすると，
つまりこんな感じに↓，

　Ａ　　Ｂ
　 1 　10
　 1 　20
　 1 　50

　 2 　40
　 2 　20
　 2 　30

　 3 　50
　 3 　10

この場合，
マクロコードは次のようになると思います。

------------------------------------
Sub 空白セルに合計を算出()

' 変数mySubtotal(小計) の初期化
mySubtotal = 0
' 変数mySum(合計) の初期化
mySum = 0

' 最終行の取得
LastRow = Range("A65536").End(xlUp).Row

' 最終行の次の行まで繰り返し
For i = 1 To LastRow + 1

' A列が空白セルでなかったらB列を足す
If Range("A" & i) <> "" Then
mySubtotal = mySubtotal + Range("B" & i).Value
' A列が空白セルだったらB列に合計を記入
Else
Range("A" & i).Value = "計"
Range("B" & i).Value = mySubtotal
mySum = mySum + mySubtotal
' 変数myTotal の初期化
mySubtotal = 0
End If

Next i

' A列の最終行の２つ下のセルに「合計」を記入
Range("A" & LastRow + 2) = "合計"
' A列の最終行の２つ下のB列セルに「合計」を出力
Range("B" & LastRow + 2) = mySum

End Sub
------------------------------------

まず，上の行から順に，
A列 が空白行でないかぎり，B列 の値を変数（mySubtotal）上で合計して行き，
A列が空白だと，それまでの変数上の合計を B列に書き出し，
変数上の合計を 0 にもどす。
というのを，
A列の最終セルの次のセルまで繰り返しているだけです。

合計 mySum の方は，
mySubtotal を 0 に戻す前に，
加算後代入して行き，最後に A列 の最終行の２つ下のB列セルに「合計」を出力しているだけで，
全体の流れから言うと副産物に近いです。

変数の宣言は省略しました。
また，実際のデータを見ないとエラーの推測ができないので，エラー処理は入れていません。

お礼

思っていた通りの結果が出ました！
ありがとうございました。

回答No.4

Wendy02

#1さんのご指摘のように、なぜ、マクロかという問題が残りますね。

計算されるデータは、特殊な状態にあるものですから、当然、マクロは、その特殊な状態をチェックする必要が出てきます。私のマクロの半分以上は、そのチェックに費やされています。また、すでに計算されたもの（ただし、私のマクロで計算されたもの)に対しては、再実行が可能なように作られています。

このような場合は、最初からコードを書くほうが楽だと思います。

Sub BlankEnterSubTotal()
　Dim titleChk As Integer
　Dim myRng As Range
　Dim myArea As Range
　Dim ar As Range
　Dim strArea As String
　Dim dummy As Range

　'一行目に項目があるか、チェック
　If VarType(Range("A1").Value) = vbString Then titleChk = 1
　'一行目が空ならマクロを抜ける
　If IsEmpty(Range("A1")) Then Exit Sub
　Set myRng = Range(Range("B1").Offset(titleChk), Range("B65536").End(xlUp))

　'データチェック
　On Error Resume Next
　Set dummy = myRng.SpecialCells(4) 'xlCellTypeBlanks
　On Error GoTo 0
　If dummy Is Nothing Then
　　If MsgBox("すでに、計算されているか、空白行のないデータです" & vbCrLf & _
　　　"範囲の計算式を消去してやり直しますか？", vbQuestion + vbOKCancel, "式の消去") = vbCancel Then
　　　GoTo Endline
　　End If
　End If
　On Error Resume Next
　Set dummy = myRng.SpecialCells(xlCellTypeFormulas, 23)
　On Error GoTo 0
　If dummy Is Nothing Then
　　MsgBox "このデータは、加工できないデータです。終了します。", vbQuestion
　　GoTo Endline
　Else
　　With dummy
　　　.ClearContents
　　　.Offset(, -1).ClearContents
　　　Set myRng = Range("B2", Range("B65536").End(xlUp))
　　End With
　End If

　'計算実行
　Application.ScreenUpdating = False
　Set myArea = myRng.SpecialCells(2, 1) 'xlCellTypeConstants, xlNumbers
　For Each ar In myArea.Areas
　　With ar
　　　.Cells(.Cells.Count + 1).FormulaLocal = "=SUBTOTAL(9," & .Address(0, 0) & ")"
　　　.Cells(.Cells.Count + 1).Offset(, -1).Value = "計"
　　End With
　Next ar
　With myRng
　　.Cells(.Count + 2).FormulaLocal = "=SUBTOTAL(9," & .Address(0, 0) & ")"
　　.Cells(.Count + 2).Offset(, -1).Value = "合 計"
　End With
　Application.ScreenUpdating = True

Endline:
　Set myRng = Nothing
　Set myArea = Nothing

End Sub

お礼

詳しいコードをありがとうございました。
コード２と３の計は、うまくいきましたが、
コード１の計は、1行目が集計されませんでした。

回答No.3

imogasi

Sub test01()
rs = 2
d = Range("A65536").End(xlUp).Row
MsgBox d
'---
While d > rs
Cells(rs, "A").Select
re = Selection.End(xlDown).Row
MsgBox re
t = 0
For i = rs To re
t = t + Cells(i, "A")
Next i
Cells(re + 1, "A") = t
rs = re + 2
Wend
End Sub

お礼

ご回答ありがとうございました。
テスト結果は、思っていたものとは、違う表示になりました。

回答No.1

NCU

なぜ「集計」ではダメでマクロでなければならないのか、理由を記載して下さい。
マクロでなければならない場合、具体的にどこがわからないのかを明らかにして下さい。

補足

質問部分は、マクロのほんの一部分で、全体はもっと行数も列も多い複雑な表です。頻繁に利用する資料作成のため、マクロで作成しています。
一つのコードのまとまりの最初の行と最後の行を見つける方法が分かりません。