[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『別シートからの特定文字列に一致するデータの集計』（もも）
こんにちは
今昨年の4月から3月の売上金額の集計をしようとしたのですが
出来ればボタンで一回でずらーって集計されればいいなーって思ってます。
A B C D E F
1 分類 表示月
2 R2.04
3 商品名 ランク 契約金額 売上金額 未納金額
4
5
6
7
8
9
10
集計用のシートに3行目からこんな感じで表のタイトルがあります。
これは月ごとのシートと同じタイトルです。
そしてA2セルにはリストで商品の分類があり、B2には集計したい月のリストがあります。
月のリストと各月別シートの文字は同じにしているので、A2セルの文字列をB2セルのシート名から集計するようにしたいです。
なお、各月別シートには商品名がランダムで記入されているので
重複している商品名の金額類は和を表示したいです。
またボタンで起動させたいのでマクロにて作動したいです。
宜しくお願いします。
＜ 使用 Excel：unknown、使用 OS：unknown ＞
一つにまとめてピボットテーブルにした方が早そうですけど… （コナミ） 2021/06/08(火) 15:04
Sub 個別集計()
Dim ws01, ws02 As Worksheet
Dim I, M, lRow, mRow As Long
Dim kensaku As String
Set ws01 = Worksheets(Range("B2").Value)
Set ws02 = Worksheets("個別集計")
kensaku = ws02.Range("B6") '検索する商品名を「商品名」から選択
lRow = ws01.Cells(Rows.Count, "B").End(xlUp).Row
mRow = 9 'シート「個別集計」に転記する開始行の9行目を設定
For I = 6 To lRow
If ws01.Cells(I, "L") Like "[" & kensaku & "]*" Then 'シート「月別」から指定した商品名に該当する項目を検索する。
ws02.Range("Q" & mRow & ":AC" & mRow).Value = ws01.Range("M" & I & ":Y" & I).Value '検索条件に該当する項目をシート「個別集計」に転記する
mRow = mRow + 1 '転記する行に対して＋１加算する。
End If
Next I
End Sub
ここからなんですけど
今の状態が例えば
A B C D E
１ 商品名 梱包 製造工場 契約金額 契約個数
２ 塩ビ管 〇 第１ 50 10
３ 塩ビ管 × 第２ 40 8
４ 塩ビ管 〇 第１ 50 10
５ 塩ビ管 〇 第１ 60 12
６ 鉄パイプ × 第１ 40 8
７ 鉄パイプ 〇 第２ 30 6
８ 塩ビ管 × 第１ 50 10
９ 塩ビ管 〇 第２ 60 12
こんな感じで環形の物をずらっとぬきだしました。
この中でA,B,Cが一致するものは集計したいです。
この中で仕分けをすると
塩ビ管で梱包が〇で第１
塩ビ管で梱包が〇で第２
塩ビ管で梱包が×で第１
塩ビ管で梱包が×で第２
鉄パイプで梱包が×で第１
鉄パイプで梱包が〇で第２
の6種類に分類されるのでこの項目で集計がかかるかんじです！！
（もも） 2021/06/08(火) 17:54
Sheet1
|[A] |[B] |[C] |[D] |[E]
[1]|商品名 |梱包|製造工場|契約金額|契約個数
[2]|塩ビ管 |〇 |第１ | 50| 10
[3]|塩ビ管 |× |第２ | 40| 8
[4]|塩ビ管 |〇 |第１ | 50| 10
[5]|塩ビ管 |〇 |第１ | 60| 12
[6]|鉄パイプ|× |第１ | 40| 8
[7]|鉄パイプ|〇 |第２ | 30| 6
[8]|塩ビ管 |× |第１ | 50| 10
[9]|塩ビ管 |〇 |第２ | 60| 12
Sheet2 [実行結果]
|[A] |[B] |[C]
[1]|商品名 梱包 製造工場|契約金額|契約個数
[2]|塩ビ管 〇 第１ | 160| 32
[3]|塩ビ管 × 第２ | 40| 8
[4]|鉄パイプ × 第１ | 40| 8
[5]|鉄パイプ 〇 第２ | 30| 6
[6]|塩ビ管 × 第１ | 50| 10
[7]|塩ビ管 〇 第２ | 60| 12
Option Explicit
Sub OneInstanceMain()
Dim zD As Object
Dim i As Long
Dim v() As Variant
Dim w() As Variant
Dim mkey As String
Dim kin As Double
Dim kosu As Double
Set zD = CreateObject("Scripting.Dictionary")
With Worksheets("Sheet1")
v = .Cells(1).CurrentRegion.Value
End With
For i = 1 To UBound(v, 1)
mkey = v(i, 1) & Chr(32) & v(i, 2) & Chr(32) & v(i, 3)
If Not zD.exists(mkey) Then
zD(mkey) = Array(v(i, 4), v(i, 5))
Else
kin = zD(mkey)(0)
kosu = zD(mkey)(1)
kin = kin + v(i, 4)
kosu = kosu + v(i, 5)
zD(mkey) = Array(kin, kosu)
kin = 0
kosu = 0
End If
Next
w = zD.keys
With Worksheets("Sheet2")
.UsedRange.Clear
For i = 0 To UBound(w)
.Cells(i + 1, 1) = w(i)
.Cells(i + 1, 2).Resize(, 2) = zD(w(i))
Next
.UsedRange.Columns.AutoFit
End With
Set zD = Nothing
Erase v, w
End Sub
（隠居じーさん） 2021/06/08(火) 20:11
追伸 Sheet2は初期化されます 一案ですので、ご考察時の参考程度にお止め下さいませ。 バタッと書きましたので不備な点があれば＾＾；。。。お許しをm(__)m エラー処理等考えていませんです。A^^; 多分、ご案内の有った、ピボットの方が簡単ですよ。。。挿入からピボット選んで ポチして、四角の箱に全てチェック入れるだけで同じものがｗ。。。(#^.^#)ｖ でわ m(_ _)m （隠居じーさん） 2021/06/08(火) 20:19
そこで表の範囲を
=OFFSET(R2.04!$B$5,0,0,COUNTA(R2.04!$B:$B),5)
のようにして名前をR2.04としました。ピポットではこの名前で指定しています。
5行目はタイトル行で、6行目からデータが入力されています。
1~4行目は表のタイトルや注意書きなどで埋まっています。
しかし、この方法でやってみましたがタイトル行しか名前として設定されません。
6行目以降で空白はありません。
どうすればデータの方も範囲になりますか？？
（もも） 2021/06/09(水) 09:03
こちらでは一応は、出来ましたですが。 R2.04 というお名前は、よく確認していないので何とも言い難いのですが 問題が多いかもしれません。エクセルのバージョンとＯＳの種類、 を明記の上、ピボットキャシュとの連動も合わせて、お詳しい方の 回答をお待ちください。
（隠居じーさん） 2021/06/09(水) 10:31
え〜と 私はよく元の範囲をテーブルにして テR2.04 とかテーブルの名前を変更[使えない文字列が有るので要注意です＾＾；]して ピボットの範囲にこの名前を指定しておくと、元情報に変化[値の変更、行の 増減等]があれば、ピボットの中にセルを置き、右ポチでのメーニューの更新を ポチするだけで全て反映されますよ。(#^^#)ｖ
（隠居じーさん） 2021/06/09(水) 10:56
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.