[[20210915202257]]　『マクロで条件に合うデータの足し算をしたいです。』（りんご）　ページの最後に飛ぶ

『マクロで条件に合うデータの足し算をしたいです。』（りんご）

初めまして。
関数だと出来るのですが、マクロだとどうなるのか初心者で分かりません。
このような集計をやる機会が多く、今後勉強したいと思います。
どうぞ、ご教授の程、宜しくお願いします。

下記のようなデータがあり、
転記先のA〜D列の条件を見て、転記元の品名と番号と月が一致するものの"足し算" を
転記先のE, F列に入力したいです。

〈転記元シート〉

     A     B      C       D       E      Ｆ
  1 品名    番号    1月    2月    3月    4月
  2 りんご   A01    5       7       9       3
  3 みかん   A02    3       7       6       5
  4 りんご   A02    3       1       6       2
  5 ぶどう   A02    6       6       7       6
  6 みかん   A01    3       7       6       5
  7 みかん   A03    1       4       1       5
  8 りんご   A03    3       1       6       2
  9 ぶどう   A03    2       2       7       6
 10 ぶどう   A01   6       2       7       6

〈転記先シート〉

      A     B     C     D     E     Ｆ
  1  品名   番号1  番号2  番号3    2月   3月
  2 りんご  A01                  7       9
  3 りんご  A01   A02            8      15
  4 りんご  A01   A03            8      15
  5 みかん  A01   A02   A03      18     13
  6 みかん  A01                  7       6
  7 みかん  A01   A02            14     12
  8 ぶどう  A02   A03            8      14
  9 ぶどう  A03                  2       7

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

一例です
転記先の各条件のデータが、転記元に必ずあるという前提です。

 Sub test()
    Dim dic As Object
    Dim r1 As Range, r2 As Range
    Dim v1, v2
    Dim k As Long, j As Long
    Dim s As String
    Dim e

    Set dic = CreateObject("scripting.dictionary")

    Set r1 = Worksheets("転記元").Cells(1).CurrentRegion
    v1 = r1.Value

    For k = 2 To UBound(v1, 1)
        s = v1(k, 1) & vbTab & v1(k, 2)
        Set dic(s) = CreateObject("scripting.dictionary")
        For j = 3 To UBound(v1, 2)
            dic(s)(v1(1, j)) = v1(k, j)
        Next
    Next

    Set r2 = Worksheets("転元先").Cells(1).CurrentRegion
    v2 = r2.Value

    For k = 2 To UBound(v2, 1)
        For Each e In Array(v2(k, 2), v2(k, 3), v2(k, 4))
            If IsEmpty(e) Then Exit For
            s = v2(k, 1) & vbTab & e
            For j = 5 To UBound(v2, 2)
                v2(k, j) = v2(k, j) + dic(s)(v2(1, j))
            Next
        Next
    Next

    r2.Value = v2

 End Sub

（マナ） 2021/09/15(水) 22:09

＞転記先の各条件のデータが、転記元に必ずあるという前提です。

中途半端な対応ですが

            s = v2(k, 1) & vbTab & e
            If dic.exists(s) Then
                For j = 5 To UBound(v2, 2)
                    v2(k, j) = v2(k, j) + dic(s)(v2(1, j))
                Next
            End If

（マナ） 2021/09/15(水) 22:19

マナ様
ご丁寧にありがとうございます！！
これまで勉強した事のないコードで、大変勉強になります。

v1 = r1.Valueはどういう事を表しているのか…とか、
dictionaryの使い方とか、見方がよく分からない状態ですが、
ステップインで理解してみたいと思います。
今後の勉強のヒントに、本当にありがとうございます！！
（りんご） 2021/09/15(水) 22:29

また同じ失敗をしてしまいました。
無駄に、複雑にしている…

 Sub test2()
    Dim dic As Object
    Dim r1 As Range, r2 As Range
    Dim v1, v2
    Dim k As Long, j As Long
    Dim s As String
    Dim e

    Set dic = CreateObject("scripting.dictionary")
    Set r1 = Worksheets("転記元").Cells(1).CurrentRegion
    v1 = r1.Value

    For k = 2 To UBound(v1, 1)
        For j = 3 To UBound(v1, 2)
            s = v1(k, 1) & vbTab & v1(k, 2) & vbTab & v1(1, j)
            dic(s) = v1(k, j)
        Next
    Next

    Set r2 = Worksheets("転元先").Cells(1).CurrentRegion
    v2 = r2.Value

    For k = 2 To UBound(v2, 1)
        For Each e In Array(v2(k, 2), v2(k, 3), v2(k, 4))
            If IsEmpty(e) Then Exit For
            For j = 5 To UBound(v2, 2)
                s = v2(k, 1) & vbTab & e & vbTab & v2(1, j)
                If dic.exists(s) Then
                    v2(k, j) = v2(k, j) + dic(s)
                End If
            Next
        Next
    Next

    r2.Value = v2

 End Sub

（マナ） 2021/09/16(木) 09:24

 Sub Sample()

    '変数を宣言
    Dim Sh1 As Worksheet    '転記元シート用
    Dim Sh2 As Worksheet    '転記先シート用
    Dim tmp As Double       '転記する値用
    Dim c1 As Long          'カウンタ変数（Sh1の列）
    Dim c2 As Long          'カウンタ変数（Sh2の列）
    Dim r1 As Long          'カウンタ変数（Sh1の行）
    Dim r2 As Long          'カウンタ変数（Sh2の行）
    Dim i As Long           'カウンタ変数（Sh2の列・A01～03用）

    '転記元、転記先シートを変数に格納
    Set Sh1 = Worksheets("転記元シート")
    Set Sh2 = Worksheets("転記先シート")

    For c2 = 5 To Sh2.Cells(1, Columns.Count).End(xlToLeft).Column                          'Sh2のE列以降を巡回
        For c1 = 3 To Sh1.Cells(1, Columns.Count).End(xlToLeft).Column                      'Sh1のC列以降を巡回
            If Sh1.Cells(1, c1).Value = Sh2.Cells(1, c2).Value Then                         'Sh1のc1列目とSh2のc2列目(それぞれ1行目)を比較して一致したとき（★）
                For r2 = 2 To Sh2.Cells(Rows.Count, "A").End(xlUp).Row                      'Sh2の2行目以降を巡回
                    tmp = 0                                                                 '転記する値をリセット
                    For r1 = 2 To Sh1.Cells(Rows.Count, "A").End(xlUp).Row                  'Sh1の2行目以降を巡回
                        If Sh1.Cells(r1, "A").Value = Sh2.Cells(r2, "A").Value Then         'Sh1のr2列目とSh2のr1列目（それぞれA列）を比較して一致したとき（☆）
                            For i = 2 To 4                                                  'Sh2のB列からD列を巡回
                                If Sh1.Cells(r1, "B").Value = Sh2.Cells(r2, i).Value Then   'Sh1のB列r1行セルとSh2のB～D列を比較して一致したとき
                                    tmp = tmp + Sh1.Cells(r1, c1).Value                     '転記する値にSh1★列☆行の値を足す
                                    Exit For                                                'iのループを脱出（重複加算防止）
                                End If
                            Next i
                        End If
                    Next r1
                    Sh2.Cells(r2, c2).Value = tmp                                           '（Sh1の全行を巡回後）Sh2★列☆行に転記
                Next r2
            End If
        Next c1
    Next c2
 End Sub

For...Nextループを回しまくる別案です。
内容は難しくないですがとにかくぐるぐる回していくので
大きな表になるとどんどん重たくなるのでご注意ください。
（めざめるパワー） 2021/09/16(木) 11:15

マナ様
ありがとうございます！！
書き直して頂いたもので試してみます！
ほんと感謝いたします！

めざめるパワー様
Loopでも出来るのですね！このやり方なら、私の今の知識でもギリギリ何となく理解する事ができました。
小さな表を作成する際の参考になりました(^^)
ほんとありがとうございます！！
（りんご） 2021/09/16(木) 14:14

コメント返信：

[ 一覧(最新更新順) ]

[[20210915202257]] 『マクロで条件に合うデータの足し算をしたいです。』（りんご） ページの最後に飛ぶ

[[20210915202257]]　『マクロで条件に合うデータの足し算をしたいです。』（りんご）　ページの最後に飛ぶ