マクロで小計行を入力する方法

質問

はじめまして。
過去問を検索したのですが、よく分からなかったので質問させていただきます。

数日前にマクロの練習をし始めたばかりで、分からないことが多々あるのですが、ある表を練習で作っていて詰まってしまいました。

番号　　月日　　会社名　　金額
１　　　11/1　　　A社　　　100
２　　　11/5　　　A社　　　200
３　　　11/4　　　B社　　　150
４　　　11/9　　　C社　　　300

このような表があるとして
番号　　月日　　会社名　　金額
１　　　11/1　　　A社　　　100
２　　　11/5　　　A社　　　200
　　＜空白行３行＞
３　　　11/4　　　B社　　　150
　　＜空白行３行＞
４　　　11/9　　　C社　　　300
　※空白行が３行なのは、印刷した時に会社ごとの境目を見やすくする為です。

この表をマクロを使って自動で会社ごとの境目に空白行を挿入するまではできました。
この後、金額の下に会社ごとの小計を出したいのです。

毎月各社の項目数が変化するので、小計欄を固定することが出来ません。
なので、引数の設定で詰まってしまっています。
色々なサイト様を回って

myLAST_ROW = Cells(Rows.Count, 2).End(xlUp).Row
myTOP_ROW = 2
myBOTTOM_ROW = i - 1
Set myRANGE = _
Range(Cells(myTOP_ROW, 4), Cells(myBOTTOM_ROW, 4))
Cells(i, 4).Formula = "=SUM(" & myRANGE.Address & ")"
myTOP_ROW = i + 1

というのが自分の思う内容に一番近いところまでいったのですが、

番号　　月日　　会社名　　金額
１　　　11/1　　　A社　　　100
２　　　11/5　　　A社　　　200
　　　　　　　　　　　　　300　　
３　　　11/4　　　B社　　　150
　　　　　　　　　　　　　450
４　　　11/9　　　C社　　　300
　　　　　　　　　　　　　750

のようになってしまいます。

直前のVBAはこうなっています（実際はこの前にページ設定などが入っています）。
For i = Cells(Rows.Count, myCol).End(xlUp).Row To 3 Step -1
If Cells(i, myCol) <> Cells(i - 1, myCol) Then
Rows(i).Insert
Rows(i).Insert
Rows(i).Insert

素人の文面で大変見づらく、そして分かりにくくて申し訳ないのですが、ご教授頂ければ幸いです。

回答No.5

Wendy02 · ベストアンサー

こんにちは。

>実際は金額の後にも他の内容の列が続くため、教えていただいた内容では出来ませんでした…

私のコードはほんのちょっと、列を選択するだけでできるはずですが、大量のデータでなければ、私のは使わなくてもよいです。一つずつ、データを検索していませんから、その分だけ速いはずです。ただ、挿入と数式の挿入は分離されていますから、それだけ抜き出してもよいです。

>どこを変更したら「行」の設定にできるかが分かりません。

行という意味がよくわかりませんが、以下を見ていただければよいです。
1列目から使われているのが条件です。

Sub Test1a()
　　Dim myCol As Integer
　　Dim a As Range
　　Dim i As Long
　　Dim j As Long
　　Dim n As Long
　　myCol = 3
　　'行の挿入
　　For i = Cells(Rows.Count, myCol).End(xlUp).Row To 3 Step -1
　　　　If Cells(i, myCol) <> Cells(i - 1, myCol) Then
　　　　　　Rows(i).Resize(3).Insert
　　　　End If
　　Next
　　'数式の挿入
　　For Each a In ActiveSheet.UsedRange.Columns(4).SpecialCells(xlCellTypeConstants).Areas
　　　　i = a.Cells.Count
　　　　If a.Cells(1).Row = 1 Then '1行目がタイトル行の場合
　　　　　　j = a.Rows.Count - 1
　　　　Else
　　　　　　j = a.Rows.Count
　　　　End If
　　　　 a.Cells(i).Offset(1).FormulaLocal = "=SUM(R[-" & j & "]C:R[-1]C)"
　　　　 '行全体
　　　　 a.Cells(i).Offset(1).EntireRow.Interior.ColorIndex = 6

　　　　 ''使用されている列幅だけ-1列目からという条件
　　　　 'n = ActiveSheet.UsedRange.Columns.Count
　　　　 'a.Cells(i).Offset(1).EntireRow.Resize(, n).Interior.ColorIndex = 6
　　Next
End Sub

なお、#3のレスの部分は、

res = Application.Find("=SUM(", c.Formula)
これは、マクロらしく書くなら、

if InStr(c.Formula,"=SUM")>0 Then　'または、' =1

ということだと思います。

また、
Set trg = ActiveSheet.Cells.SpecialCells(xlCellTypeFormulas, 23)
If Not trg Is Nothing Then

このコードは、キメウチにしてしまってよいと思います。しかし　 trg Is Nothing というのは、通常ではありえませんね。SpecialCells は、エラーを返しますから、trg Is Nothing は、On Error Resume Nextを使わないと、できません。

お礼

Wendy02様、何度もありがとうございました。
出来ました！！思っていた通りの表が作れて感動です！！

まだまだ勉強不足なので、これからも精進していこうと思います。
書いていただいたコードを見ながら、一つ一つ理解していこうと思います。

本当にありがとうございました！！

回答No.4

Wendy02

こんばんは。

空行を挿入した場合は、以下のように、一気に数式を入れる方法があります。
また、マクロで行う場合は、R1C1方式を使うほうが楽です。

Sub Test1()
　　Dim myCol As Integer
　　Dim a As Range
　　Dim i As Long
　　Dim j As Long
　　myCol = 3
　　'行の挿入
　　For i = Cells(Rows.Count, myCol).End(xlUp).Row To 3 Step -1
　　　　If Cells(i, myCol) <> Cells(i - 1, myCol) Then
　　　　　　Rows(i).Resize(3, 4).Insert
　　　　End If
　　Next
　　数式の挿入
　　For Each a In ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants).Areas
　　　　i = a.Cells.Count
　　　　If a.Cells(1).Row = 1 Then '1行目がタイトル行の場合
　　　　　　j = a.Rows.Count - 1
　　　　Else
　　　　　　j = a.Rows.Count
　　　　End If
　　　　 a.Cells(i).Offset(1).FormulaLocal = "=SUM(R[-" & j & "]C:R[-1]C)"
　　Next
End Sub

お礼

Wendy02様、お返事ありがとうございます。

申し訳ございません…当方の説明不足です…
実際は金額の後にも他の内容の列が続くため、教えていただいた内容では出来ませんでした…
せっかく書いていただいたのに、申し訳ございません。

R1C1方式ですね。何度か名前だけは見たことがあるのですが、しっかり勉強してみようと思います。
ありがとうございました。

回答No.3

fujillin

確認用のMsgBoxを消し忘れてました。
（消したものがこちら）

Sub test()
Dim sh As Worksheet
Dim r As Long, rRec As Long, rEnd As Long

Set sh = ActiveSheet
rEnd = sh.Cells(Rows.Count, 2).End(xlUp).Row
rRec = rEnd

For r = rEnd To 2 Step -1
If sh.Cells(r, 3) <> sh.Cells(r - 1, 3) Then
　If rRec <> rEnd Then Rows(rRec + 1 & ":" & rRec + 3).Insert
　sh.Cells(rRec + 1, 4).Formula = "=SUM(D" & r & ":D" & rRec & ")"
　rRec = r - 1
End If
Next r
End Sub

お礼

fujillin様、お返事頂きありがとうございます。こちらでまとめてお返事させて頂きます。

出来ました！！本当にありがとうございます。
質問だらけで恐縮なのですが、もう一点質問させていただいてもよろしいでしょうか？

ＳＵＭの入っている「行」に分かりやすいように色をつけたいのです。
自分なりに調べて
Sub Macro1()
Dim c, trg As Range, res
Set trg = ActiveSheet.Cells.SpecialCells(xlCellTypeFormulas, 23)
If Not trg Is Nothing Then
For Each c In Cells.SpecialCells(xlCellTypeFormulas, 23)
res = Application.Find("=SUM(", c.Formula)
If IsNumeric(res) Then
c.Interior.ColorIndex = 6
End If
Next c
End If
End Sub
でＳＵＭの「セル」に色をつけることはできたのですが、どこを変更したら「行」の設定にできるかが分かりません。

お忙しい所誠に申し訳ないのですが、こちらもご教授いただけたらと思います。
勉強不足で申し訳ございません。

回答No.2

fujillin

よくわかりませんが、3行挿入するときに式も一緒にセットしてしまえばいいのでは？

Sub test()
Dim sh As Worksheet
Dim r As Long, rRec As Long, rEnd As Long

Set sh = ActiveSheet
rEnd = sh.Cells(Rows.Count, 2).End(xlUp).Row
rRec = rEnd

For r = rEnd To 2 Step -1
If sh.Cells(r, 3) <> sh.Cells(r - 1, 3) Then
MsgBox (r)
　If rRec <> rEnd Then Rows(rRec + 1 & ":" & rRec + 3).Insert
　sh.Cells(rRec + 1, 4).Formula = "=SUM(D" & r & ":D" & rRec & ")"
　rRec = r - 1
End If
Next r
End Sub

回答No.1

pkh4989

以下のマクロを参考にしてください。
※各社の間に空欄の行が３行追加された状態でのマクロです。

Sub 小計数式設定()
　　Dim wR　　　　　As Long
　　Dim sR　　　　　As Long
　　Dim eR　　　　　As Long
　　Dim myLAST_ROW　As Long
　　Dim myTOP_ROW　 As Long
　　'
　　With ActiveSheet
　　　　myLAST_ROW = .Cells(Rows.Count, 2).End(xlUp).Row
　　　　myTOP_ROW = 2
　　　　sR = myTOP_ROW
　　　　wR = myTOP_ROW
　　　　Do While ExitFlg = False
　　　　　　'各社別最終行を求める
　　　　　　If .Cells(wR, 2).Offset(1, 0) <> "" Then
　　　　　　　　eR = .Cells(wR, 2).End(xlDown).Row
　　　　　　Else
　　　　　　　　eR = wR
　　　　　　End If
　　　　　　'小計の数式設定
　　　　　　.Cells(eR + 1, 4) = "=SUM(D" & sR & ":D" & eR & ")"
　　　　　　If eR >= myLAST_ROW Then
　　　　　　　　'終了
　　　　　　　　ExitFlg = True
　　　　　　Else
　　　　　　　　'次社の先頭行を設定
　　　　　　　　sR = eR + 1
　　　　　　　　wR = .Cells(eR, 2).End(xlDown).Row
　　　　　　End If
　　　　Loop
　　End With
End Sub

お礼

お返事ありがとうございます。
ただ、私の入力場所が悪かったのか、もしくは何か違うことをしてしまったのか、ＳＵＭは入ったのですが、引数が一つ前の会社名の合計ＳＵＭも含めてしまうようになってしまい、質問文の一番下の表のようになってしまいました。

もう少しマクロを勉強して、pkh4989様のおっしゃられた内容が分かるようになりたいと思います。
ありがとうございました。