エクセルで行を挿入して小計合計を出したい

質問ですが，以下の参考としたマクロについて，データが１支店１件しかない場合は行を挿入せずにこのままとしたい場合はどのように修正すれば良いか教えていただけませんでしょうか。
1支店２件以上のデータがある場合は，以下の参考としたマクロのとおり行を挿入して小計を計算表示する。

　支店コード1001 20000円 200円　　←　行挿入不要　小計無し
　　　　　　1002 30000円 200円
　　　　　　1002 45000円 300円
　　　　　　小計 75000円 500円

参考にした質問・アドレス
Ａ列に支店コード（４桁の数値）、Ｊ列に金額、Ｋ列に手数料があります。
支店は５箇所でデータは１支店あたり１００～５００行ほどあります。全支店のデータが連続しています。
１．支店コードの最終行の下に１行挿入し、Ｊ列，Ｋ列の小計を計算する。
２．最後の支店の小計の下に一行あけてＪ列，Ｋ列の合計をしたい。
Sub test01()
d = Range("a2").CurrentRegion.Rows.Count
' MsgBox d
Cells(d + 1, 1) = "END"
Dim st1, gt1, st2, gt2 As Long
st1 = 0: gt1 = 0: st2 = 0: gt2 = 0
mk = Cells(2, 1)
'==========
For i = 2 To 10000
If Cells(i, 1) = "END" Then Exit For '最終行判定
If Cells(i, 1) = mk Then '前行とコード同じか
'------今回行分加算
st1 = st1 + Cells(i, 2)
st2 = st2 + Cells(i, 3)
Else
mk = Cells(i, 1)
'--------小計
Cells(i, 1).EntireRow.Insert
Cells(i, 1) = "小計"
Cells(i, 2) = st1
gt1 = gt1 + st1
st1 = 0
Cells(i, 3) = st2
gt2 = gt2 + st2
st2 = 0
'-----今回行分加算
i = i + 1
st1 = st1 + Cells(i, 2)
st2 = st2 + Cells(i, 3)
End If
Next i
'============終了
'-------小計
Cells(i, 1) = "小計"
MsgBox st1
Cells(i, 2) = st1: gt1 = gt1 + st1: st1 = 0
Cells(i, 3) = st2: gt2 = gt2 + st2: st2 = 0
'-------合計
Cells(i + 1, 1) = "合計"
Cells(i + 1, 2) = gt1
Cells(i + 1, 3) = gt2
End Sub
　
アドレス　http://oshiete.goo.ne.jp/qa/414647.html

No.2 ベストアンサー 回答者： WindFaller 回答日時： 2014/12/29 13:43

こんにちは。

そのコードは、imogasiさんのだったのですね。内容は分かりにくいけれども、実行できますね。
ここでは、おなじみでしたが、書かなくなったお一人です。彼独特のコードは、思い出深いものがあります。ピボットという方法が、常識的ではあるけれども、一応、元のコードと同じ手法で書きます。合計値は、計算式にしました。

レイアウトは、以下のように、1行目は、「支店コード　　金額　　手数料」と想定したマクロです。

1　　　　　　支店コード……
2　　　　　　1001　　20000円 200円
3　　　　　　1002　　30000円 200円
4　　　　　　1002　　45000円 300円
5　　　　　　小計　　75000円 500円

タイトル行がなくて、A1から始まるのなら、CL ="A", i =1 というように書き換えてください。

'//
Sub Test01()
　　Dim rng As Range
　　Dim i As Long
　　Dim cnt As Long
　　Dim cnt2 As Long
　　Const CL As String = "I" '最初の列
　　i = 2　　'開始行
　　Set rng = Cells(i, CL).CurrentRegion.Columns(1)
　　'二重計算のミスを防ぐ
　　If Application.CountBlank(rng) > 0 Then
　　　　MsgBox "空白行があって、正しく実行されません。", vbExclamation
　　　　Exit Sub
　　ElseIf Application.CountIf(rng, "小　計") > 0 Then
　　　　MsgBox "すでに計算されたものだと思われます。", vbExclamation
　　　　Exit Sub
　　End If
　　Application.ScreenUpdating = False
　　Do
　　　　If IsNumeric(Cells(i, CL).Value) Then
　　　　　　If Cells(i, CL).Value > 0 Then
　　　　　　　　cnt = cnt + 1
　　　　　　End If
　　　　　　If Cells(i, CL).Value <> Cells(i, CL).Offset(1).Value And cnt > 1 Then
　　　　　　　　Cells(i, CL).Offset(1).Resize(, 3).Insert Shift:=xlDown　　'3列挿入
　　　　　　　　With Cells(i + 1, CL)
　　　　　　　　　　.Value = "小　計"
　　　　　　　　　　.Offset(, 1).FormulaLocal = "=SUBTOTAL(9,R[-" & cnt & "]C:R[-1]C)"
　　　　　　　　　　.Offset(, 2).FormulaLocal = "=SUBTOTAL(9,R[-" & cnt & "]C:R[-1]C)"
　　　　　　　　End With
　　　　　　　　i = i + 1: cnt = 0
　　　　　　ElseIf Cells(i, CL).Value <> Cells(i, CL).Offset(1).Value And cnt = 1 Then
　　　　　　　　cnt = 0
　　　　　　End If
　　　　End If
　　　　i = i + 1
　　Loop Until Cells(i, CL).Value = ""
　　With Cells(i, CL)
　　　　.Value = "合　計"
　　　　.Offset(, 1).FormulaLocal = "=SUM(R[-" & rng.Rows.Count & "]C:R[-1]C)"
　　　　.Offset(, 2).FormulaLocal = "=SUM(R[-" & rng.Rows.Count & "]C:R[-1]C)"
　　End With
　　Application.ScreenUpdating = True
　　Set rng = Nothing
End Sub
'//

この回答へのお礼

動作結果もバッチリでした。当初参考にした質問・アドレスにあるマクロよりもわかりやすくその他にも応用がしやすいものと思います。ありがとうございました。

お礼日時：2014/12/29 16:28

No.1 回答者： keithin 回答日時： 2014/12/28 23:41

sub macro1()

　dim r as long
’掃除　ブックを保存してからマクロを実行する事
　range(range("A65536").end(xlup).offset(1), range("A65536")).entirerow.delete shift:=xlshiftup
　activeworkbook.save

’集計
　range("A:K").subtotal _
　 groupby:=1, _
　 function:=xlsum, _
　 totallist:=array(10, 11), _
　 replace:=true, _
　 pagebreaks:=false, _
　 summarybelowdata:=true

’１行集計の検出と削除
　activesheet.outline.showlevels rowlevels:=2
　for r = range("A65536").end(xlup).row to 3 step -1
　　if rows(r).summary then
　　　if rows(r - 2).hidden = false then
　　　　rows(r).delete shift:=xlshiftup
　　　end if
　　end if
　next r

’表示の調整と片づけ
　activesheet.outline.showlevels rowlevels:=3
　range("A:A").replace what:="*集計", replacement:="小計", lookat:=xlwhole
　range("A:A").font.bold = false
　range("A65536").end(xlup).entirerow.insert shift:=xlshiftdown
　range("A:K").clearoutline
end sub




＞１支店１件しかない場合は行を挿入せずにこのままとしたい

１件しかない行を非常に見つけにくくなるため、そのようにはしないことを推奨します。

この回答へのお礼

早速の回答ありがとうございました。希望どおりの結果を得ることができました。また，ピポットで集計するマクロを初めて確認することができましたので今後の参考とさせていただきます。

お礼日時：2014/12/29 06:08