質問ですが,以下の参考としたマクロについて,データが1支店1件しかない場合は行を挿入せずにこのままとしたい場合はどのように修正すれば良いか教えていただけませんでしょうか。
1支店2件以上のデータがある場合は,以下の参考としたマクロのとおり行を挿入して小計を計算表示する。
支店コード1001 20000円 200円 ← 行挿入不要 小計無し
1002 30000円 200円
1002 45000円 300円
小計 75000円 500円
参考にした質問・アドレス
A列に支店コード(4桁の数値)、J列に金額、K列に手数料があります。
支店は5箇所でデータは1支店あたり100~500行ほどあります。全支店のデータが連続しています。
1.支店コードの最終行の下に1行挿入し、J列,K列の小計を計算する。
2.最後の支店の小計の下に一行あけてJ列,K列の合計をしたい。
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ベストアンサー
- 回答日時:
こんにちは。
そのコードは、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
'//
動作結果もバッチリでした。当初参考にした質問・アドレスにあるマクロよりもわかりやすくその他にも応用がしやすいものと思います。ありがとうございました。
No.1
- 回答日時:
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
’1行集計の検出と削除
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
>1支店1件しかない場合は行を挿入せずにこのままとしたい
1件しかない行を非常に見つけにくくなるため、そのようにはしないことを推奨します。
早速の回答ありがとうございました。希望どおりの結果を得ることができました。また,ピポットで集計するマクロを初めて確認することができましたので今後の参考とさせていただきます。
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
関連するカテゴリからQ&Aを探す
おすすめ情報
- ・漫画をレンタルでお得に読める!
- ・人生のプチ美学を教えてください!!
- ・10秒目をつむったら…
- ・あなたの習慣について教えてください!!
- ・牛、豚、鶏、どれか一つ食べられなくなるとしたら?
- ・【大喜利】【投稿~9/18】 おとぎ話『桃太郎』の知られざるエピソード
- ・街中で見かけて「グッときた人」の思い出
- ・「一気に最後まで読んだ」本、教えて下さい!
- ・幼稚園時代「何組」でしたか?
- ・激凹みから立ち直る方法
- ・1つだけ過去を変えられるとしたら?
- ・【あるあるbot連動企画】あるあるbotに投稿したけど採用されなかったあるある募集
- ・【あるあるbot連動企画】フォロワー20万人のアカウントであなたのあるあるを披露してみませんか?
- ・映画のエンドロール観る派?観ない派?
- ・海外旅行から帰ってきたら、まず何を食べる?
- ・誕生日にもらった意外なもの
- ・天使と悪魔選手権
- ・ちょっと先の未来クイズ第2問
- ・【大喜利】【投稿~9/7】 ロボットの住む世界で流行ってる罰ゲームとは?
- ・推しミネラルウォーターはありますか?
- ・都道府県穴埋めゲーム
- ・この人頭いいなと思ったエピソード
- ・準・究極の選択
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
エクセルのデータがない行には...
-
Excel VBAでオートフィルタで抽...
-
数値に見えるものはすべて数値...
-
VB.net
-
エクセルで空白行を削除する ...
-
【VBA】条件に一致しない行を削...
-
Excel マクロ 検索結果を別シ...
-
エクセルのVBAで指定した行数の...
-
Excel VBA オートフィルタの結...
-
エクセルで階層図を作る方法
-
vbaエクセルマクロについて she...
-
【VBA】条件に一致しない行を削...
-
エクセルVBAでデータの蓄積方法?
-
マクロで最終行を取得してコピ...
-
Excel97 指定した行だけマク...
-
evcel VBAについて
-
Access2003レポート:最終ペー...
-
【至急】Excel 同一人物の情報...
-
Excel VBAの質問。行のコピーと...
-
EXCEL マクロで下から10行目ま...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
【VBA】条件に一致しない行を削...
-
エクセルで空白行を削除する ...
-
マクロで最終行を取得してコピ...
-
エクセルのデータがない行には...
-
数値に見えるものはすべて数値...
-
【マクロ】A列最終行までを、カ...
-
VB.net
-
Excel VBAでオートフィルタで抽...
-
【VBA】条件に一致しない行を削...
-
エクセルで階層図を作る方法
-
列から特定の文字列検索→該当以...
-
Excel マクロ 検索結果を別シ...
-
各個体に対する平均値の自動計...
-
Excel97 指定した行だけマク...
-
空白を複数行一気に挿入するには?
-
EXCEL2007マクロ/オートフィル...
-
Access2003レポート:最終ペー...
-
EXCEL VBAでA列にある空白行よ...
-
Excel VBA オートフィルタの結...
-
VBAでの重複データに色付け
おすすめ情報