[[20210607091152]]　『月別シートから特定製品のみの集計』（みっち）　ページの最後に飛ぶ

『月別シートから特定製品のみの集計』（みっち）

R3.09、R3.10、・・・R4.8までの一年分の12シートがあります。
その他に個別集計というシートを作成しています。

それぞれの月別のシートでは

リンゴ、イチゴ、バナナ・・・などさまざまな種類の商品があり
さらにリンゴには王林、富士・・・などと詳細で分類があります。

これらが

        A    　   B     　  C       D       E      
1   　品目　　　種類　　　今月　　来月　 再来月　
2　　リンゴ　　王林　　　 ２０　　３０　　２０
3　　リンゴ　　富士　　　 １０　　１０　　１０
4　　イチゴ　　あまおう　 ３０　　３０　　２０
5　　リンゴ　　王林　　　 １０　　１０　　１０
6　　イチゴ　　紅い雫　　 １５　　３０　　２０
7

のように表になっています。
表のつくりは全月別シートで同じですが、順番は注文順で上からなので各月でバラバラです。

これを集計シートに抽出し、集計したいと思っています。
具体的には集計シートに同様の表をつくり、セルにシート名、品目のリストをつくり、その分だけを集計したいです。
集計シートのレイアウトは

        A    　   B     　  C       D       E    
1　 月のリスト
2  品目のリスト
3   　品目　　　種類　　　今月　　来月　 再来月　
4　　
5
6
7
8
9

のようにし、Ａ１でR3.09を選び、Ａ２でリンゴを選んだ際はシート[R3.9]から[リンゴ]のみを抜き出し、種類別に集計してリストかしたいです。

        A    　   B     　  C       D       E    
1　 　R3.09
2  　リンゴ
3   　品目　　　種類　　　今月　　来月　 再来月　
4　　リンゴ　　王林　　　 ３０　　４０　　３０
5　　リンゴ　　富士　　　 １０　　１０　　１０
6

↑重複している王林が集計された。

宜しくお願いします

＜使用 Excel：Excel2016、使用 OS：Windows10 ＞

 月別シートのF列を作業列として使う。
 各月別シートのF2セルに
 =COUNTIFS(A$2:A2,A2,B$2:B2,B2)
 と入力して下へフィルコピーする。
（ねむねむ） 2021/06/07(月) 10:02

 次に集計シートのA4セルに
 =IFERROR(INDEX(INDIRECT(ADDRESS(1,COLUMN(A1),,,$A$1)&":"&ADDRESS(100,COLUMN(A1))),AGGREGATE(15,6,ROW($2:$100)/((INDIRECT(ADDRESS(2,1,,,$A$1)&":"&ADDRESS(100,1))=$A$2)*(INDIRECT(ADDRESS(2,6,,,$A$1)&":"&ADDRESS(100,6))=1)),ROW(A1))),"")
 と入力し、B列および下へフィルコピーする。
（ねむねむ） 2021/06/07(月) 10:03

 ここで式中のADDRESS関数内の100及びROW関数内の100は各月別シートのデータの最大行数以上で同じ数値としてくれ。
 また、
 ADDRESS(2,6,,,$A$1)&":"&ADDRESS(100,6))
 の２か所の6は月シートで作業列としたF列の列番号(A列から数えて6列目)なので作業列を変更した場合にはそれに合わせて変更してくれ。
（ねむねむ） 2021/06/07(月) 10:07

 最後にC4セルに
 =IF($A4="","",SUMIFS(INDIRECT(ADDRESS(1,COLUMN(C1),,,$A$1)&":"&ADDRESS(100,COLUMN(C1))),INDIRECT(ADDRESS(1,1,,,$A$1)&":"&ADDRESS(100,1)),$A4,INDIRECT(ADDRESS(1,2,,,$A$1)&":"&ADDRESS(100,2)),$B4))
 と入力して右及び下へフィルコピーしてくれ。
 ここでもADDRESS関数内の100は月シートでの最大行数以上としてくれ。
（ねむねむ） 2021/06/07(月) 10:09

ねむねむさん
早速のご回答ありがとうございます。
大変申し訳ございませんがこちらをマクロで処理したいと考えていました。
記入不足ですいません。

理由は今は説明のためにリンゴなどでしましたが、本来の品目や種類が多岐にわたり、行数でいうと数千から万を超える可能性があり、全てのセルに関数を入れてしまうと大変計算が重くなってしまうためです。

最終的にマクロ実行をボタン化にし、常に計算されないようにする目論見です。
（みっち） 2021/06/07(月) 10:26

少しレイアウトが異なりますけど
Power Queryですべての表をひとつにし
Pivot Tableで集計するのはどうですか

（マナ） 2021/06/07(月) 12:58

マクロが使いたければ、こんな感じが簡単です。

手作業で、どれかひとつのシートをデータソースにPivot Tableで集計。
これをひな形にします。

マクロでは、データソースの変更とフィルターを実行するだけ。

（マナ） 2021/06/07(月) 17:28

 こんばんは！
こういうのは対象シートがあったりなかったり、対象品目があったりなかったりするのが厄介なところだと思います。
それさえクリアすればわりと簡単です。。。
ということで入力規則を使うのがいいと思います。

 各シートにデータを入力して「事前準備」を走らせると個別集計シートのA1に入力規則が出来ます。
その入力規則でシートを選ぶとそのシートの品目がA2の入力規則に出てきます。
その状態で「個別集計」を走らせるとデータを集計してきます。

 ちょっと確認作業をあまりやっていないので駄目な時があるかもしれません。その時は、、頑張ってください。。。(おおっっいい(^^;）
なお、何分にもずぶのど素人が片手間で書いたコードですのでお気に召さない箇所等は適当にアレンジしていただけますと幸甚です。

 これ↓を個別集計シートのシートモジュールに貼り付けます。
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim MyDic As Object
Dim y As Variant
Dim i As Long
If Target.Address <> "$A$1" Then Exit Sub
If Target.Value = "" Then Exit Sub
Set MyDic = CreateObject("Scripting.Dictionary")
With Sheets(Target.Value)
    For i = 2 To .Range("A" & Rows.Count).End(xlUp).Row
        MyDic(.Range("A" & i).Value) = Empty
    Next
End With
y = Join(MyDic.Keys, ",")
With Me.Range("A2").Validation
    .Delete
    .Add Type:=xlValidateList, Formula1:=y
End With
Set MyDic = Nothing
End Sub

 これを↓標準モジュールに貼り付けます。
Option Explicit
Sub 事前準備()
Dim ws As Worksheet
Dim x() As Variant
Dim y As Variant
Dim n As Long
For Each ws In Worksheets
    If ws.Name <> "個別集計" Then
        ReDim Preserve x(n)
        x(n) = ws.Name
        n = n + 1
    End If
Next
y = Join(x, ",")
With Sheets("個別集計")
    With .Range("A1").Validation
        .Delete
        .Add Type:=xlValidateList, Formula1:=y
    End With
End With
Erase x
End Sub
Sub 個別集計()
Dim MyDic As Object
Dim v As Variant
Dim x() As Variant
Dim y As Variant
Dim z As Variant
Dim シート As String
Dim 品目 As String
Dim i As Long
Set MyDic = CreateObject("Scripting.Dictionary")
With Sheets("個別集計")
    シート = .Range("A1").Value
    If シート = "" Then Exit Sub
    品目 = .Range("A2").Value
    With Sheets(シート)
        v = .Range("A1").CurrentRegion.Resize(, 5).Value
        For i = LBound(v, 1) + 1 To UBound(v, 1)
            If 品目 = v(i, 1) Then
                If Not MyDic.Exists(品目 & "," & v(i, 2)) Then
                   ReDim x(2)
                   x(0) = v(i, 3)
                   x(1) = v(i, 4)
                   x(2) = v(i, 5)
                   MyDic(品目 & "," & v(i, 2)) = x
                Else
                    x = MyDic(品目 & "," & v(i, 2))
                    x(0) = x(0) + v(i, 3)
                    x(1) = x(1) + v(i, 4)
                    x(2) = x(2) + v(i, 5)
                    MyDic(品目 & "," & v(i, 2)) = x
                End If
            End If
        Next
    End With
    x = MyDic.Keys
    y = MyDic.Items
    z = Application.Transpose(Application.Index(v, 1, 0))
    ReDim Preserve z(LBound(z, 1) To UBound(z, 1), LBound(z, 2) To UBound(x) + 2)
    For i = LBound(x) To UBound(x)
        z(1, i + 2) = Split(x(i), ",")(0)
        z(2, i + 2) = Split(x(i), ",")(1)
        z(3, i + 2) = y(i)(0)
        z(4, i + 2) = y(i)(1)
        z(5, i + 2) = y(i)(2)
    Next
    With Application
        .EnableEvents = False
            .ScreenUpdating = False
                .Rows(3).Insert
                .Range("A4").CurrentRegion.Clear
                .Range("A3").Resize(UBound(z, 2), UBound(z, 1)).Value = Application.Transpose(z)
            .ScreenUpdating = True
        .EnableEvents = True
    End With
End With
Set MyDic = Nothing
Erase x, y, v, z
End Sub
（SoulMan） 2021/06/07(月) 19:39

コメント返信：

[ 一覧(最新更新順) ]

[[20210607091152]] 『月別シートから特定製品のみの集計』（みっち） ページの最後に飛ぶ

[[20210607091152]]　『月別シートから特定製品のみの集計』（みっち）　ページの最後に飛ぶ