質問ですが,以下の参考としたマクロについて,データが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.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件しかない行を非常に見つけにくくなるため、そのようにはしないことを推奨します。
早速の回答ありがとうございました。希望どおりの結果を得ることができました。また,ピポットで集計するマクロを初めて確認することができましたので今後の参考とさせていただきます。
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
'//
動作結果もバッチリでした。当初参考にした質問・アドレスにあるマクロよりもわかりやすくその他にも応用がしやすいものと思います。ありがとうございました。
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- Visual Basic(VBA) VBAで時間(00:00形式)を積算(足し算)したい 1 2022/11/15 17:04
- Visual Basic(VBA) countifsについての質問 3 2023/03/08 13:45
- Excel(エクセル) VBAで組み合わせ算出やCOUNTIFSの処理を高速化したいです。 4 2022/04/07 02:38
- Visual Basic(VBA) エラーコード1004 6 2022/06/09 14:12
- Excel(エクセル) VBAの指示の内容 昨日こちらでご教示頂いたのですが初心者な為、一つ一つの指示が何をやっているのかわ 2 2022/10/25 18:08
- Visual Basic(VBA) コード名シートA列と集計シートA列のコードが一致したら、コード名シートA5からk12の範囲をコピーし 1 2022/08/29 23:46
- Visual Basic(VBA) VBA処理追加 こちらでご教示頂いたのですが回答完了させてしまいましたのでこちらからまた質問させてく 2 2022/10/27 09:57
- Visual Basic(VBA) 追記する列を増やしたい 2つのデータを検索・照合して元データにないデータを下記マクロで商品名を追記し 9 2022/10/05 10:50
- Visual Basic(VBA) 最終列の右へSUM関数を作成するため下記コードを実行しましたが、最終列「10月28日」が上書きされて 3 2022/12/05 20:32
- Visual Basic(VBA) 別シートから年齢別の件数をカウントしたいの続き 5 2023/01/24 00:16
関連するカテゴリからQ&Aを探す
おすすめ情報
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
マクロで最終行を取得してコピ...
-
数値に見えるものはすべて数値...
-
エクセルのVBAで指定した行数の...
-
EXCELマクロで自動改行
-
エクセルのデータがない行には...
-
マクロにて指定の文字間の文字...
-
Excel97 指定した行だけマク...
-
エクセルで空白行を削除する ...
-
【VBA】条件に一致しない行を削...
-
各個体に対する平均値の自動計...
-
エクセルで特定の文字が入って...
-
Excel VBAで列を行に変換するには
-
【VBA】条件に一致しない行を削...
-
Excelで行データがあるセルから...
-
VBAでの重複データに色付け
-
エクセルで頭が一緒のものは横...
-
Access2003レポート:最終ペー...
-
Excel VBAでオートフィルタで抽...
-
EXCEL VBAでA列にある空白行よ...
-
エクセルのVBAについて
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
エクセルで空白行を削除する ...
-
数値に見えるものはすべて数値...
-
エクセルのデータがない行には...
-
マクロで最終行を取得してコピ...
-
【VBA】条件に一致しない行を削...
-
【VBA】条件に一致しない行を削...
-
エクセルのVBAで指定した行数の...
-
VB.net
-
Excel VBAでオートフィルタで抽...
-
マクロにて指定の文字間の文字...
-
Excel97 指定した行だけマク...
-
EXCEL VBAでA列にある空白行よ...
-
excel2021で実行できないマクロ...
-
Excel 別ブックから該当データ...
-
VBAでの重複データに色付け
-
Excel VBA オートフィルタの結...
-
エクセルで階層図を作る方法
-
VBAで特定の行と一つ上の行を削...
-
【至急】Excel 同一人物の情報...
-
Excelで、マウスで範囲を選択し...
おすすめ情報