EXCELでマクロを使って、小計、合計の出し方

Question

１．部の中にそれぞれ、営業１課、営業２課、…があり、社員と売上金額が表示されている下記のようなデータがあります。
部、課、社員の数は、実際はもっとたくさんあり、それぞれの件数は、毎月変化します。
マクロを使って、課毎計、部毎計、総合計を出す方法を教えて下さい。
試しに作りましたら、下記のような結果になり、うまくいきません。
元データ
部課社員金額
A営業１課a10
A営業１課b20
A営業１課c30
A営業２課d40
A営業２課e50
A営業２課f60
Ｂ営業１課ｇ70
Ｂ営業１課h80
Ｂ営業１課I90
Ｂ営業２課j100
Ｂ営業２課k110
Ｂ営業２課l120

実行結果
　　　　　　　×　正解
部課社員金額　金額
A営業１課a10　10
A営業１課b20　20
A営業１課c30　30
　営業１課　計　60　60
A営業２課d40　40
A営業２課e50　50
A営業２課f60　60
　営業２課　計210　150
A　合計　　110　210
Ｂ営業１課ｇ70　70
Ｂ営業１課h80　80
Ｂ営業１課I90　90
　営業１課　計240　240
Ｂ営業２課j100　100
Ｂ営業２課k110　110
Ｂ営業２課l120　120
　営業２課　計570　330
Ｂ　合計　　230　570
総合計　　780　780

Sub 合計計算()
    Sheets("元").Select
    Sheets("元").Copy Before:=Sheets(2)
    Dim GYO1 As Long     '部 グループの先頭行
    Dim GYO2 As Long     '部 グループの最終行
    Dim GYO3 As Long     '課グループの先頭行
    Dim GYO4 As Long     '課グループの最終行
    Dim GYO As Long      '小計、合計行
    Dim strFORMULA As String
    GYO = 2
    '空白でない間、次の作業を繰り返す
    Do While Cells(GYO, 1).Value <> ""
        GYO1 = GYO
        GYO = GYO + 1
     '部が同じ間、次の作業を繰り返す
        Do While Cells(GYO, 1).Value = Cells(GYO1, 1).Value
                 GYO = GYO + 1
       '課が同じ間、次の作業を繰り返す
          GYO3 = GYO
            Do While Cells(GYO, 2).Value = Cells(GYO3, 2).Value
                 GYO = GYO + 1
            Loop
            
         '課計
          GYO2 = GYO - 1
          Rows(GYO).Insert
          Cells(GYO, 2).Value = Cells(GYO3, 2).Value & "　計"
          Cells(GYO, 4).FormulaR1C1 = "=SUBTOTAL(9,R" & GYO1 & "C:R" & GYO2 & "C)"
          GYO = GYO + 1
        Loop
        
        '部計
        GYO4 = GYO - 1
        Rows(GYO).Insert
        Cells(GYO, 1).Value = Cells(GYO1, 1).Value & "　合計"
        Cells(GYO, 4).FormulaR1C1 = "=SUBTOTAL(9,R" & GYO3 & "C:R" & GYO4 & "C)"
        GYO = GYO + 1
     Loop
     
    ' 総合計
    Cells(GYO, 1).Value = "総合計"
    Cells(GYO, 4).FormulaR1C1 = "=SUBTOTAL(9,R1C:R" & GYO2 & "C)"
    Range("A1").Select
    End Sub
２．尚、この質問のように表形式のデータを間隔をあけて原稿を作成しても確認画面になると、間隔が詰まります。間隔が詰まらない方法も教えて下さい。

Wendy02 · Accepted Answer

こんにちは。

>最初のレイアウトのようにそれぞれの部、課毎の下に計を出せないでしょうか？

#2 さんのご指摘のように、[ピボットテーブル]や、データの中の[集計]を使ったほうが簡単だと思います。

それと、「実行結果」というもののレイアウトが良く理解できていません。なぜ、計算データを二重にする必要があるのか分かりません。

この種のマクロは、素人もベテランの人も、内容はほとんど変わりません。有志の方で、構わない、作りますという方は、ここのカテゴリでも、他の掲示板でもいますが、なるべく、個人のマクロの勉強の過程の中で開発していくようにお願いしたいと思っています。ただ、あまり実務に直結したマクロの勉強には、ほとんどならないとは思います。私も、今回、たまたま別の方の質問の余韻が残っていたので、#1に書いたまでで、本来、以下のようなマクロは現在は掲示板にはほとんど書いていません。

一応、書いた責任上は、ここにコードを出しておきます。

'標準モジュール

Sub SortEnter()
　　Dim i As Long
　　Dim EndRow As Long
　　Dim RowDiff As Long
　　
　　Application.ScreenUpdating = False
　　'ソート
　　With Range("A1").CurrentRegion
　　　　.Sort _
　　　　Key1:=.Range("A2"), Order1:=xlAscending, _
　　　　Key2:=.Range("B2"), Order2:=xlAscending, _
　　　　Header:=xlYes, _
　　　　OrderCustom:=1, MatchCase:=False, _
　　　　Orientation:=xlTopToBottom, SortMethod:=xlPinYin, _
　　　　DataOption1:=xlSortNormal, DataOption2:=xlSortNormal
　　　　RowDiff = .Cells(.Cells.Count).Row - .Rows.Count
　　　　EndRow = .Cells(.Cells.Count).Row
　　　　For i = .Rows.Count To 3 Step -1
　　　　'部
　　　　　　If StrComp(Trim(.Cells(i, 1).Value), Trim(.Cells(i - 1, 1).Value), 1) <> 0 Then
　　　　　　　　.Cells(i, 1).Resize(2).EntireRow.Insert
　　　　　　　　i = i - 2
　　　　　　End If
　　　　　　'課
　　　　　　If StrComp(Trim(.Cells(i, 2).Value), Trim(.Cells(i - 1, 2).Value), 1) <> 0 Then
　　　　　　　　.Cells(i, 1).EntireRow.Insert
　　　　　　　　i = i - 1
　　　　　　End If
　　　　Next i
　　End With
　　Call FormulaSumEnter
　　Application.ScreenUpdating = True
End Sub
Private Sub FormulaSumEnter()
　　'数式を入れるマクロ
　　Dim FstRow As Long
　　Dim FstRow1 As Long
　　Dim FstRow2 As Long
　　Dim TotalRow As Long
　　Dim i As Long
　　TotalRow = Range("A65536").End(xlUp).Row + 2 '合計欄の2行を加える
　　FstRow = 2 '計算の最初の行
　　FstRow1 = FstRow
　　FstRow2 = FstRow
　　
　　For i = 2 To TotalRow
　　　　If Cells(i, 2).Value = "" Then
　　　　　　Cells(i, 4).FormulaLocal = "=SUBTOTAL(9,R[" & CStr(FstRow1 - i) & _
　　　　　　"]C:R[-1]C)"
　　　　　　Cells(i, 2).Value = Cells(i - 1, 2).Value & " 計"
　　　　　　FstRow1 = i + 1
　　　　　　
　　　　　　If Cells(i + 1, 2).Value = "" Then
　　　　　　　　Cells(i + 1, 4).FormulaLocal = "=SUBTOTAL(9,R[" & CStr(FstRow2 - i - 1) & "]C:R[-2]C)"
　　　　　　　　Cells(i + 1, 1).Value = Cells(i - 2, 1).Value
　　　　　　　　Cells(i + 1, 2).Value = "合　計"
　　　　　　　　FstRow2 = i
　　　　　　End If
　　　　End If
　　Next i
　　Cells(i, 1).Value = "総合計"
　　Cells(i, 4).FormulaLocal = "=SUBTOTAL(9,R[" & CStr(FstRow - i + 1) & "]C:R[-2]C)"
End Sub

KenKen_SP · Answer

> 最初のレイアウトのものをマクロで作成したいのです。

行の列：　[部][課][人]
集計欄：　[金額]

で、出力レイアウトはかなり近いものになりますが。。

マクロで実現されたいようですが、この操作を記録すると、
参考になるコードが得られると思います。

あとは、それにデータ件数が変動した場合の処理を付け加える
だけでかなり実用的になると思いますよ。

一案ですが。

imogasi · Answer

質問者のほとんどは、自分の既に考え付いたやり方（ロジック）コードを修正箇所を教えてくれというのが多い。
しかし洗練されていないのが多い。
ーー
基本は、ピヴォトテーブルのように便利な、他人（プロ）の組んだソフトを使うことです。
他にもソートして、「データ」「集計」など使えそう
この集計する程度のことで、自作していたら、勉強にはなるが、時間がもったいないだけ。
ーー
しかしあえて、私が回答で何度も書いたが、ソート法という、昔ながらの方法を書きます。先達の知恵で、味わい深い点があると思うので、参考にしてください。
（１）シートをコピーをとり、以下はコピー先で処理
（２）部＋課（キーという）でソート（＋の意味わかりますか）
（３）第１（レコード）行目のデータのキーを、変数を設けて保存し、売上を足しこむ変数に足しこみ
（４）次のレコード（行）を対象に、直前レコードとキー部分が変わったか、比較する。コントロールブレイクの検出という。
（５）変わらなければ、売上を足すだけー＞（４）へ行って繰り返し。
（６）変わったら、直前のキーと今までの合計を書き出す。
　　合計は０（ご破算）に
　　キーは今の行のものに改める
　　合計（上記で０にした）に今の行のものを足す。
　　－＞（４）へ行って繰り返し
（６）最後が来たら、今溜まっているキーと合計を書き出し。
ーー
以上は課（小）合計を説明したが、部合計用の変数も用意し、（４）で課とあわせて、部が変わったかチェックし、変わるごとに、溜めた部と合計を書き出し、かつ合計を０にする。
課が変わるごとに、課合計を部合計に加える方法でもよい。

KenKen_SP · Answer

ピボットテーブルでできますよ。レイアウトは例えば、

列の単に [人]
行の欄に [部][課]
集計欄に [金額]

をそれぞれドロップし、OKをクリックするだけです。

Wendy02 · Answer

こんばんは。

最初に、
>間隔が詰まらない方法も教えて下さい。
確か、全角空白でも縮まってしまいますので、「.（コンマ）」を入れるのですが、ただ、コードの場合は、エラーが発生してしまいます。だから、「'.」となるのですが、他のみなさんはどうかしりませんが、私は、テキストエディタ上で、レイアウトをもう一度、整えますので、あまり気になさらずによいです。

ところで、前回のものをあわせて、マクロでずいぶん難しいことをされるなって思います。ワークシートを扱うマクロは、本当に難しいのです。だから、なるべく、こういうのは、無理にでも関数で処理する方向性のほうがよいと思います。実務では、私個人としては、本当に、以下のようなマクロを書くかというと、よほど困らなければ、手作業でしてしまいます。

なお、ご質問ですが、並べ替えやレイアウト自体をいじっても、

課毎計、部毎計、総合計

ということは出来ないように思います。

単に、ユニークな部、課をはじき出しておいて、それでもって、SUMIF で出すのがよいのですが、以下のような方法もあるというひとつの例です。今回は、テキスト比較モードになっていますので、全角・半角などのブレに関しては、ひとまとめにしてくれます。


'標準モジュール用

Sub SubTotalMacro()
　　Dim dicBu As Object
　　Dim dicKa As Object
　　Dim Rng As Range
　　Dim i As Long
　　Dim j As Long
　　Dim k As Long
　　
　　Set dicBu = CreateObject("Scripting.Dictionary")
　　Set dicKa = CreateObject("Scripting.Dictionary")
　　dicBu.CompareMode = 1 'テキスト比較モード
　　dicKa.CompareMode = 1 'テキスト比較モード
　　
　　'集計データの左端
　　Set Rng = Range("A2", Range("A65536").End(xlUp))
　　
　　Application.ScreenUpdating = False
　　For i = 1 To Rng.Rows.Count
　　　　If Rng(i, 4).Value <> "" Then
　　　　　　If dicBu.Exists(Rng(i, 1).Value) = False Then
　　　　　　　　dicBu.Add Rng(i, 1).Value, Rng(i, 4)
　　　　　　Else
　　　　　　　　dicBu(Rng(i, 1).Value) = dicBu(Rng(i, 1).Value) + Rng(i, 4)
　　　　　　End If
　　　　　　
　　　　　　If dicKa.Exists(Rng(i, 2).Value) = False Then
　　　　　　　　dicKa.Add Rng(i, 2).Value, Rng(i, 4)
　　　　　　Else
　　　　　　　　dicKa(Rng(i, 2).Value) = dicKa(Rng(i, 2).Value) + Rng(i, 4)
　　　　　　End If
　　　　End If
　　Next i
　　j = dicBu.Count
　　k = dicKa.Count
　　'集計結果
　　i = i + 1
　　Cells(i + 1, 2).Value = "部別集計"
　　i = i + 1
　　Cells(i + 1, 3).Resize(j).Value = WorksheetFunction.Transpose(dicBu.Keys)
　　Cells(i + j + 1, 2).Value = "課別集計"
　　Cells(i + j + 2, 3).Resize(k).Value = WorksheetFunction.Transpose(dicKa.Keys)
　　
　　Cells(i + 1, 4).Resize(j).Value = WorksheetFunction.Transpose(dicBu.Items)
　　Cells(i + j + 2, 4).Resize(k).Value = WorksheetFunction.Transpose(dicKa.Items)
　　Cells(i + j + k + 2, 2).Value = "総 計"
　　Cells(i + j + k + 2, 4).Value = WorksheetFunction.Sum(dicBu.Items)
　　
　　Application.ScreenUpdating = True
　　
　　Set Rng = Nothing
　　Set dicBu = Nothing
　　Set dicKa = Nothing
End Sub

EXCELでマクロを使って、小計、合計の出し方

こんにちは。

この回答への補足

> 最初のレイアウトのものをマクロで作成したいのです。

質問者のほとんどは、自分の既に考え付いたやり方（ロジック）コードを修正箇所を教えてくれというのが多い。

ピボットテーブルでできますよ。

この回答への補足

こんばんは。

この回答への補足

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング