重複データ集約と照合

Question

実現したいこと

やりたい事：4パターン、8パターンシートの内容を照合し、照合結果シートのボタンで照合結果を出力したいです。

前提環境①：照合結果シートのA3～E3項目は、フォーマットとして用意されている。
条件①：4パターン、8パターンシートの行数は300行数を想定
条件②：4パターン、8パターンシートの照合キーは、部品コード
条件③：4パターン、8パターンシート毎で、以下データ集約を行った後、4パターン、8パターンシートの照合を行いたい。
●第一データ集約条件
①重複部品コードがあった場合、１つに集約する。その際、数量は加算、部品名は上書き集約
②重複しない部品コードは、数量、部品名そのまま
●第二データ集約条件
①部品コードに対して、4パターン、8パターンシートの数量を表示
②部品名は、上書き
※8パターンシート11行名の部品_Fと4パターンシート11行目の部品Fとなっているが、部品コードは同一の為、どちらかに上書きされる形にしたい。
③照合結果は以下条件のように表示させたい

完成イメージ

詳細①

詳細②

詳細③

発生している問題・エラーメッセージ

実行時エラー450
引数の数が一致していません。または不正なプロパティを指定しています。

該当のソースコード

Sub 重複データ集約し照合()

Dim myDic As Object                 'Dictionaryオブジェクト使用
Dim myPc As Variant               '部品コード変数
Dim myQu As Variant              '数量変数
Dim myPn As Variant                 '部品名変数
Dim myList As Variant                '部品コード、数量、部品名配列
Dim i As Long                              '配列カウント数
Dim cWs As Worksheet               '4パターンシート
Set cWs = Worksheets("4パターン") '4パターン変数
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "4パターン_仮" '4パターン_仮シート作成
Dim cWs1 As Worksheet '4パターンシートコピー
Set cWs1 = Worksheets("4パターン_仮") '4パターン_仮変数

    Set myDic = CreateObject("Scripting.Dictionary")
    
    '数量,部品コード,部品名のデータを配列に格納※社内外列は照合に不要だが、列分割での格納方法が分からない
    cWs.Activate
    myList = Range("A4", Range("A" & Rows.Count). _
                     End(xlUp)).Resize(, 4).Value
    
    
    '連想配列にデータを格納　1次元
    For i = 1 To UBound(myList, 1)

        '部品コードが空欄かチェック
        If Not myList(i, 3) = Empty Then
            If Not myDic.exists(myList(i, 3)) Then  '配列重複チェック

                '重複しない部品コードを取得※数量,部品コード,部品名を取得したいが、複数Itemの場合エラー発生
                myDic.Add Key:=myList(i, 3), Item:=myList(i, 1), Item:=myList(i, 4)
            Else

                '数量を加算
                myDic(myList(i, 3)) = myDic(myList(i, 3)) + Val(myList(i, 1))
            End If
        End If
    Next

    '[部品コード] 重複していないリストを格納
    myPc = myDic.keys

    '[部品名]   品目を格納
    myPn = myDic.items

    '[数量]   品目コードの合計を格納
    myItem = myDic.items

    'リストを出力
    For i = 0 To UBound(myPc)
        cWs1.Cells(i + 2, 1).Value = myPc(i)
        cWs1.Cells(i + 2, 2).Value = myPn(i)
        cWs1.Cells(i + 2, 3).Value = myQu(i)
    Next

    '開放※setで使用したものを閉じる(DBへのアクセス、変数)
    Set myDic = Nothing

End Sub

試したこと

やりたい事から、以下方針でプログラムを考えたのですが、初期段階でつまづきました。
また、やりたい事が複雑であるため、道筋も見えず、お力添えをお願いします。

第一データ集約条件を目指して、4パターン、8パターンシート毎で集約処理を実施しようとしたら、
部品コード、数量、部品名の2つ以上の変数処理を行うとことでエラーが発生しました。

Answer 1

dictionaryを３つ使う方法にしました。
４パターン用（キー：部品コード、値：数量）
８パターン用（キー：部品コード、値：数量）
部品名用（キー：部品コード、値：部品名）

４パターンシートと８パターンシートは同じフォーマットであることが前提です。
データは４行目から開始

照合結果シートは、３行目までが見出し、データは４行目から開始とします。
（マクロが設定するのは４行目以降のみ）

シート名は、以下の通りとします。
４パターンシート：4パターン
８パターンシート：8パターン
照合結果シート：照合結果
（シート名が実際と異なる場合は、あなたのほうでマクロを修正してください）

１．4パターンの部品コードと数量を記憶（同一部品コードは１つにまとめる）
２．8パターンの部品コードと数量を記憶（同一部品コードは１つにまとめる）
３．4パターンの部品コードを基準に照合結果へ出力
その時、８パターンの部品コードがあれば、同時に出力し、８パターンにdictionaryから当該部品コードを削除
４．残りの8パターンの部品コードを照合結果へ出力
という流れになります。

Option Explicit

Public Sub 重複データ集約照合()
    Dim Dic8 As Object      '８パターン用
    Dim Dic4 As Object      '４パターン用
    Dim dicN As Object      '部品名用
    Dim ws8 As Worksheet    '８パターンシート
    Dim ws4 As Worksheet    '４パターンシート
    Dim wsS As Worksheet    '照合シート
    Dim wrow As Long
    Dim key As Variant
    Dim res As String
    Set Dic8 = CreateObject("Scripting.Dictionary")    '連想配列の定義
    Set Dic4 = CreateObject("Scripting.Dictionary")    '連想配列の定義
    Set dicN = CreateObject("Scripting.Dictionary")    '連想配列の定義
    Set ws8 = Worksheets("8パターン")
    Set ws4 = Worksheets("4パターン")
    Set wsS = Worksheets("照合結果")
    Call MakeDict(ws4, Dic4, dicN)  '4パターンシート読み込み
    Call MakeDict(ws8, Dic8, dicN)  '8パターンシート読み込み
    '照合シートの4行目以降をクリア
    wsS.Rows("4:" & Rows.count).ClearContents
    '照合シート設定
    wrow = 4
    '4パターンを処理
    For Each key In Dic4.keys
        'A列数量 4パターン
        wsS.Cells(wrow, "A").Value = Dic4(key)
        'B列数量 8パターン
        If Dic8.exists(key) = True Then
            wsS.Cells(wrow, "B").Value = Dic8(key)
            Dic8.Remove key
        Else
            wsS.Cells(wrow, "B").Value = 0
        End If
        'C列部品コード
        wsS.Cells(wrow, "C").Value = key
        'D列部品名
        wsS.Cells(wrow, "D").Value = dicN(key)
        'E列照合結果
        If wsS.Cells(wrow, "B").Value = 0 Then
            res = "部品コード不一致"
        ElseIf wsS.Cells(wrow, "A").Value = wsS.Cells(wrow, "B").Value Then
            res = "部品コード一致・数量一致"
        Else
            res = "部品コード一致・数量不一致"
        End If
        wsS.Cells(wrow, "E").Value = res
        wrow = wrow + 1
    Next
    '8パターンの残りの部品コードを処理
    For Each key In Dic8.keys
        'A列数量 4パターン
        wsS.Cells(wrow, "A").Value = 0
        'B列数量 8パターン
        wsS.Cells(wrow, "B").Value = Dic8(key)
        'C列部品コード
        wsS.Cells(wrow, "C").Value = key
        'D列部品名
        wsS.Cells(wrow, "D").Value = dicN(key)
        'E列照合結果
        res = "部品コード不一致"
        wsS.Cells(wrow, "E").Value = res
        wrow = wrow + 1
    Next
    MsgBox ("完了")
End Sub
'8/4パターンシート処理
Private Sub MakeDict(ByVal ws As Worksheet, ByRef dicT As Object, ByRef dicN As Object)
    Dim maxrow As Long
    Dim wrow As Long
    Dim key As String
    maxrow = ws.Cells(Rows.count, "A").End(xlUp).Row    'A列の最大行取得
    For wrow = 4 To maxrow
        key = ws.Cells(wrow, "C").Value
        '新規の部品コードなら数量クリア
        If dicT.exists(key) = False Then
            dicT(key) = 0
        End If
        dicT(key) = dicT(key) + ws.Cells(wrow, "A").Value   '数量加算
        '新規の部品名なら部品名登録
        If dicN.exists(key) = False Then
            dicN(key) = ws.Cells(wrow, "D").Value
        End If
    Next
End Sub

Comments

[jabe]

対応ありがとうございます。
また、私のやりたい事をプログラム化していただき、助かりました。
実行したことろ問題なく動作しました。
dictionaryを複数使用して、集約作業を簡潔に出来る事知りませんでした。
勉強し直します。

[jabe]

すいません。聞き忘れていました。
お手数掛けますが、以下コードの狙いを教えて下さい。
Dic8.Remove key'Remove一部を削除するのは何の為でしょうか？

３．4パターンの部品コードを基準に照合結果へ出力
その時、８パターンの部品コードがあれば、同時に出力し、８パターンにdictionaryから当該部品コードを削除
↑上記の”８パターンにdictionaryから当該部品コードを削除”するというところが理解出来ていなくて。

[tatsu99]

ここで行っていることは
①４パターンにあって、８パターンにないもの（８パターン数量に０をセット）
②４パターンにあって、８パターンにあるもの（８パターン数量にその数をセット）
です。
これが、終わった後で、
４．残りの8パターンの部品コードを照合結果へ出力をおこないますが、
これは、「８パターンにあって、４パターンにないもの」の処理です。
その為には、上記の②で４パターンにあり８パターンにもあるものを削除しておけば、
残りは、「８パターンにあって、４パターンにないもの」だけになります。

[jabe]

回答ありがとうございます。
理解できました。
4の処理の為、②の削除が必要になってくるんですね。

Answer 2

複雑な案件なので細かく精査はしてませんが、エラーの部分についてだけ解決策を。

            If Not myDic.exists(myList(i, 3)) Then  '配列重複チェック

                '重複しない部品コードを取得※数量,部品コード,部品名を取得したいが、複数Itemの場合エラー発生
                myDic.Add Key:=myList(i, 3), Item:=myList(i, 1), Item:=myList(i, 4)
            Else

                '数量を加算
                myDic(myList(i, 3)) = myDic(myList(i, 3)) + Val(myList(i, 1))
            End If

上記のコードで「引数の数が一致していません。」というエラーになるの、Addメソッドの引数は2つなのに無視して３つ指定しているのが原因ですね。

いろいろ方法はあると思いますが、
数量と部品名をArray関数で配列にまとめて、Itemに格納すればどうでしょう。

    Dim a As Variant

            If Not myDic.exists(myList(i, 3)) Then  '配列重複チェック
                myDic.Add Key:=myList(i, 3), Item:=Array(myList(i, 1), myList(i, 4))
            Else
                '数量を加算
                a = myDic(myList(i, 3))
                a(0) = a(0) + 1
                myDic(myList(i, 3)) = a
            End If

Comments

[jabe]

対応ありがとうございます。
エラー解消されました。
3つ以上の項目がある場合、Array関数で対応する事ができる事知りませんでした。
勉強になりました。