[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『集計表について』(tt21)
下記のA:Gの表からQ:Uのような集計表をワンクリックで作成するにあたり、解法のアドバイスをお願いします。
(説明)
・同じ項目は収入、支出を集計する
・同じ項目に複数の内訳がある場合は、複数の内訳の集計を(小計)として最上位に出力し、その下に内訳の集計を出力する
・度数は項目あるいは内訳の重複回数を意味します(チェック用です)
・異なる項目内に同じ内訳が存在します(香典の例)
C/R A B C D E F G - Q R S T U 1 - - - - - - - - - - - - - 2 No. 日付 項目 内訳 詳細 収入 支出 - 項目 内訳 収入 支出 度数 3 - - 繰越金 前期 - 0 0 - 繰越金 前期 0 0 1 4 - - 会費 新入会員 - 45000 0 - 会費 新入会員 45000 0 1 5 - - 活動費 役員会 - 0 5092 - 活動費 (小計) 18000 82135 3 6 - - 活動費 送迎会 - 0 77043 - 役員会 0 5092 1 7 - - 補助金 △△会 - 0 3000 - 送迎会 18000 77043 2 8 - - 慶弔費 ○○神社 - 0 15000 - 補助金 (小計) 5000 3000 2 9 - - 活動費 送迎会 - 18000 0 - △△会 0 3000 1 10 - - 慶弔費 香典 - 0 5000 - 香典 5000 0 1 11 - - 慶弔費 香典 - 0 5000 - 慶弔費 (小計) 0 25000 3 12 - - 補助金 香典 - 5000 0 - ○○神社 0 15000 1 13 - - - - - - - - 香典 0 10000 2
(お願い)
一応、Dictionaryを2つ使って解決はしておりますが、いかにも“遠回り”のような気がしております。
できればキーは一つにしてもっと効率よくできないかと思っています。
(特に出力のところ…キーの分割とか効率悪いと思っています)
“こういうふうに考えたらどうか”というヒントをもらえないでしょうか?
ピボットテーブルも検討しましたが、ワンクリックでできるメドが立たなかったのと知識不足で
現時点では考慮外としています。
(私の検討結果)
実コードは他の処理もありダラダラと長いので、関連のみ書き換えて示します。
Sub test() Dim sh As Worksheet '対象シート Dim sr As Long '開始行(入力式) Dim er As Long '最終行(自動取得) Set sh = ActiveSheet '明細シート xxxxx sr=3:er=99 With sh '/ 集計;キーを二つ持つ Dim dic_1 As Object, dic_2 As Object 'dic_1;項目, dic_2;項目|内訳 Dim ky1, ky2 '各Key Dim yi As Long, yo As Long '収入,支出 Dim ct1 As Long, ct2 As Long '重複度数 Dim r As Long '行カウンタ Set dic_1 = CreateObject("Scripting.Dictionary") Set dic_2 = CreateObject("Scripting.Dictionary") For r = sr To er ky1 = .Cells(r, "C").Value ky2 = .Cells(r, "C").Value & "|" & .Cells(r, "D").Value yi = .Cells(r, "F").Value yo = .Cells(r, "G").Value '..項目を登録 If Not dic_1.exists(ky1) Then dic_1.Add ky1, Array(yi, yo, 1) Else yi = dic_1(ky1)(0) + .Cells(r, "F").Value yo = dic_1(ky1)(1) + .Cells(r, "G").Value ct1 = dic_1(ky1)(2) + 1 dic_1(ky1) = Array(yi, yo, ct1) End If '..項目|内訳を登録 yi = .Cells(r, "F").Value yo = .Cells(r, "G").Value If Not dic_2.exists(ky2) Then dic_2.Add ky2, Array(yi, yo, 1) Else yi = dic_2(ky2)(0) + .Cells(r, "F").Value yo = dic_2(ky2)(1) + .Cells(r, "G").Value ct2 = dic_2(ky2)(2) + 1 dic_2(ky2) = Array(yi, yo, ct2) End If '/ 出力;重複度数に応じて出力していく Dim buf As Variant Dim k As Long, e As Long, rp As Long Dim ct As Long '重複度数 Dim co As String '内訳 '..格納(Dic_2) Dim ary_1, ary_2 ary_1 = dic_2.keys ary_2 = dic_2.items k = sr For Each buf In dic_1 ct = dic_1.Item(buf)(2) rp = 1 'ループ回数 For e = 0 To UBound(ary_2) Dim sp sp = Split(ary_1(e), "|") 'Dic_2キーを分割 If buf = sp(0) Then 'Dic_1キーとDic_2キーの項目を比較 If ct = 1 Then '重複=1 .Cells(k, "Q").Value = buf '項目 .Cells(k, "R").Value = sp(1) '内訳(Dic_2) .Cells(k, "S").Resize(1, 3).Value = ary_2(e) '収入/支出/重複度数(Dic_2) Exit For Else If rp = 1 Then .Cells(k, "Q").Value = buf .Cells(k, "R").Value = "(小計)" .Cells(k, "S").Resize(1, 3).Value = dic_1.Item(buf) rp = rp + 1 End If k = k + 1 .Cells(k, "R").Value = sp(1) '内訳(Dic_2) .Cells(k, "S").Resize(1, 3).Value = ary_2(e) '収入/支出/重複度数(Dic_2) End If End If Next e k = k + 1 Next buf End With End Sub
確認は明日以降でレス遅くなるかと思いますが、よろしくお願いします。
※質問での表の書き方がよくわからず見苦しくてすみません
本題から外れますが、方法教えていただけると助かります
< 使用 Excel:Excel2010、使用 OS:Windows10 >
試しにやってみたら結構面倒でした。 やっぱりピボットテーブルがおススメですね
Sub sample()
Dim 集計 As Dictionary, aRow As Range Dim 項目 As String, 内訳 As String, 収入 As Long, 支出 As Long
Set 集計 = CreateObject("Scripting.Dictionary")
For Each aRow In Range("C3", Cells(Rows.Count, "C").End(xlUp)).Resize(, 5).Rows 項目 = aRow.Cells(1, 1) 内訳 = aRow.Cells(1, 2) 収入 = aRow.Cells(1, 4) 支出 = aRow.Cells(1, 5) If Not 集計.Exists(項目) Then 集計.Add 項目, CreateObject("Scripting.Dictionary") End If With 集計.Item(項目) If Not .Exists(内訳) Then .Add 内訳, CreateObject("Scripting.Dictionary") With .Item(内訳) .Add "収入", CreateObject("Scripting.Dictionary") .Add "支出", CreateObject("Scripting.Dictionary") End With End If End With With 集計.Item(項目).Item(内訳) If 収入 > 0 Then With .Item("収入") .Add .Count + 1, 収入 End With End If If 支出 > 0 Then With .Item("支出") .Add .Count + 1, 支出 End With End If End With Next
i = 3 For Each buf1 In 集計.Keys Cells(i, "I") = buf1 Cells(i, "J") = "小計" j = 1 For Each buf2 In 集計.Item(buf1) Cells(i + j, "J") = buf2 With 集計.Item(buf1).Item(buf2) S = 0 For Each buf3 In 集計.Item(buf1).Item(buf2).Item("収入").Items S = S + buf3 Next Cells(i + j, "K").Value = S S = 0 For Each buf3 In 集計.Item(buf1).Item(buf2).Item("支出").Items S = S + buf3 Next Cells(i + j, "L").Value = S Cells(i + j, "M").Value = .Item("収入").Count + .Item("支出").Count End With j = j + 1 Next Cells(i, "K").Resize(, 3).FormulaR1C1 = "=SUBTOTAL(9,R[1]C:R[" & j - 1 & "]C)" i = i + j Next End Sub (´・ω・`) 2021/07/27(火) 00:48
少しレイアウトが違いますが、問題はそこですか。
こだわりがなければ、マクロ不要なのですが…
(マナ) 2021/07/27(火) 07:45
(マナ) 2021/07/27(火) 07:49
(tt21) 2021/07/27(火) 09:41
老婆心ながら。 >本件は、実用化後には後任に引継いでいきたいと考えています。(未来永劫?) >おそらくこれからの後任者は私同様にピボットテーブルに馴染みがないかと思います。
↑について、後任の方がVBAを扱える保障もないのでは。 もし仮にVBAを理解しコーディングできる人だとしても… MSの仕様変更や、予期せぬエラーでマクロが動かなくなったときに 後任の方が他人のソースを読み解き動作確認する手間と ピボットテーブルを理解する手間を天秤にかけたら 間違いなくピボットテーブルの理解のほうが早いと思います。
なんせ、ピボットテーブルの使い方はネットに山ほどあります。 仮にピボットテーブル自体の仕様変更があっても、重要・便利な機能のため すぐに解説記事があがることでしょう。
食わず嫌いせず、一度学んでみてはいかがでしょうか? (山姥) 2021/07/27(火) 09:49
>ユーザー定義型に関するコンパイルエラーが出ました
方針をピボットテーブルでやる方向にするなら、私のコード見なくていいです。
一応動かして見るなら、変数の定義部を Dim 集計 As Object, aRow As Range に変えてください。 もとのままだと参照設定が必要なので。 オススメはピボットテーブルです。 Excelの標準機能でできることを、わざわざVBAで組むのは時間の無駄です (趣味や勉強ならOKですが業務でしょ)
>おそらくこれからの後任者は私同様にピボットテーブルに馴染みがないかと思います。 イチから初める人が、VBAに馴染むかピボットテーブルに馴染むかを選ぶなら、 ピボットテーブルを選ぶようにしてあげてください。 (´・ω・`) 2021/07/27(火) 10:02
ピボットテーブルでは提示しましたアウトプット(Q:U表)の様式にできるイメージが今は湧きませんが、いい機会なので検討してみたいと思います。
(マナさんのいわれるアウトライン形式?がキーでしょうか?)
(tt21) 2021/07/27(火) 23:26
(1)データ範囲を選択 (2)[挿入]タブ→[テーブル]グループ→[ピボットテーブル] (3)ダイアログがでてきたら、ピボットテーブルの配置場所を指定して [OK] (4)空のピボットテーブルができて、右側にピボットテーブルフィールドの設定のウインドウでます。 上のフィールドを、下のボックスにドラッグして集計方法を設定します。 (5)[行]のボックスに [項目]フィールド , [内訳]フィールド を ポイポイとドラッグドロップ (6)[シグマ値]のボックスに[収入]フィールド,[支出]フィールド、[内訳]フィールドをポイポイポイ (7)メニューの[ピボットテーブルツール]→[デザイン]タブ→[レイアウト]グループ→[レポートのレイアウト]→[アウトライン形式で表示]
まずここまでやって、気に入らなければ、それからということで。 (´・ω・`) 2021/07/28(水) 11:03
・「集計.Add 項目, CreateObject("Scripting.Dictionary")」のようにDictionaryの要素にCreateObjectを記述すること
・「集計.Item(項目).Item(内訳)」のようにItemを連結した書き方
一応調べてみましたが未だに理解できないため、よろしくお願いします…
(貧弱なオツムと業務ではないので隙間時間でやっているため、時間かかってすみません)
(tt21) 2021/07/28(水) 11:13
そこ、こだわります? DictionaryのアイテムにDictionaryを入れてるだけですが、 その解読やめてピボットテーブル試してって何回書けばいいんですかね (´・ω・`) 2021/07/28(水) 11:24
個人のタスクであれば何を使っても問題ないものと思いますが、
業務でしかも引き継ぎを念頭に置かれているのであれば、
説明があっても、あなた自身が理解に苦しむようであれば、
候補にできないのではないですか?
ちなみに、
DictionaryのアイテムにDictionaryを入れる手法は結構出てきます。
"dictionary 入れ子 VBA"などとして、ここの学校や広くネット検索すれば
でてきます。
集計.Item(項目).Item(内訳)は、
集計.Item(項目)で項目に対応するitemであるdictionaryが返り、
さらに .Item(内訳)とすることで、
key内訳に対応するitemが取得できるということです。
(γ) 2021/07/28(水) 12:17
Sub sample() Const pvtName As String = "集計表" Dim pvCache As PivotCache, pvTable As PivotTable 'Dim pvtAlreadyExixt As Boolean Dim pvtAlreadyExist As Boolean ' 7/29 修正 On Error Resume Next Set pvTable = ActiveSheet.PivotTables(pvtName) pvtAlreadyExist = Err = 0 On Error GoTo 0 If pvtAlreadyExist Then With pvTable .PivotCache.SourceData = Range("C2", Cells(Rows.Count, "C").End(xlUp)).Resize(, 5).Address .PivotCache.Refresh .ClearTable End With Else Set pvCache = ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, _ SourceData:=Range("C2", Cells(Rows.Count, "C").End(xlUp)).Resize(, 5)) ' 7/29 修正 'Version:=xlPivotTableVersion15) ' 7/29 修正 Set pvTable = pvCache.CreatePivotTable(TableDestination:=Range("I2"), _ TableName:=pvtName) ' 7/29 修正 'DefaultVersion:=xlPivotTableVersion15) ' 7/29 修正 End If With pvTable .HasAutoFormat = False ' 7/29 追加 .RowAxisLayout xlOutlineRow .AddDataField .PivotFields("収入"), "収入計", xlSum .AddDataField .PivotFields("支出"), "支出計 ", xlSum .AddDataField .PivotFields("内訳"), "度数", xlCount With .PivotFields("項目") .Orientation = xlRowField .Position = 1 End With With .PivotFields("内訳") .Orientation = xlRowField .Position = 2 End With End With End Sub (´・ω・`) 2021/07/28(水) 17:17
これからもよろしくお願いします…
(ピボットテーブル学習中に出た疑問点は、別途投稿させていただくつもりです)
(tt21) 2021/07/28(水) 22:29
>ンパイルエラーが出て どこで? (´・ω・`) 2021/07/28(水) 22:56
>Dim pvtAlreadyExixt As Boolean ↓ Dim pvtAlreadyExist As Boolean
(マナ) 2021/07/28(水) 23:12
そのパラメータは、削除してください。
バージョン指定しなくても大丈夫です。
(マナ) 2021/07/28(水) 23:58
毎度すみません。 こっそり直しました。 (´・ω・`) 2021/07/29(木) 07:02
今回、Dictionaryの知識が増えた上にピボットテーブルに触れることができて本当によかったです。
まだ学習途上ですが、これからもよろしくお願いします…
(tt21) 2021/07/29(木) 17:30
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.