2つの項目が一致したときに別シートから値をコピー（足し算）するVBAを作りたいです。

2つの項目（サイズ、カラー）が一致したときに別シートから数量をコピーし加算していくVBAを作りたいです。
カラーの項目は複数ある色の中の１つに該当すれば良いという判定を付けたいです。

■シート名：注文データ

サイズ カラー 数量
----------------------------------------
S 白 100
L 白 100
XL 白 100
S 黒 100
M 黒 100
S 青 100
M 青 100
XL 青 100


■シート名：外注表
サイズ カラー 数量
------------------------------------------------
S 白
M 白
L 白
XL 白
S 黒
M 黒
L 黒
XL 黒
S 黒 青
M 黒 青
L 黒 青
XL 黒 青

マクロを実行すると・・・注文データの数量を外注表の該当行へ加算
↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓

■シート名：外注表

サイズ カラー 数量
------------------------------------------------
S 白 100
M 白 -
L 白 100
XL 白 100
S 黒 100
M 黒 100
L 黒 -
XL 黒 -
S 黒 青 200
M 黒 青 200
L 黒 青 -
XL 黒 青 100


どうか宜しくお願いします。

No.3 ベストアンサー 回答者： めぐみん_ 回答日時： 2018/11/10 18:00

No.2です。

そこまでややこしくする必要なかったですね。

Sub megu_2()
　　Dim myDic As Object
　　Dim r As Range, st As String
　　Dim v

　　Set myDic = CreateObject("Scripting.Dictionary")

　　With Worksheets("注文データ")
　　　　For Each r In .Range("A2", .Cells(Rows.Count, 1).End(xlUp))
　　　　　　st = r.Value & "_" & r.Offset(, 1).Value
　　　　　　If Not myDic.Exists(st) Then myDic.Add st, 0
　　　　　　myDic(st) = myDic(st) + r.Offset(, 2).Value
　　　　Next
　　End With

　　With Worksheets("外注表")
　　　　.Range("C2", .Cells(Rows.Count, 3)).ClearContents ' 数量の列の値を事前に消去
　　　　For Each r In .Range("A2", .Cells(Rows.Count, 1).End(xlUp))
　　　　　　For Each v In Split(r.Offset(, 1), " ")
　　　　　　　　st = r.Value & "_" & v
　　　　　　　　If myDic.Exists(st) Then _
　　　　　　　　　　r.Offset(, 2).Value = r.Offset(, 2).Value + Val(myDic(st))
　　　　　　Next
　　　　　　r.Offset(, 2).Value = IIf(r.Offset(, 2).Value = "", "-", r.Offset(, 2).Value)
　　　　Next
　　End With
　　Set myDic = Nothing
End Sub

差し替えて下さい。

No.2 回答者： めぐみん_ 回答日時： 2018/11/10 17:47

No.1です。

Sub megu()
　　Dim myDic As Object
　　Dim r As Range, st As String, s As String
　　Dim v

　　Set myDic = CreateObject("Scripting.Dictionary")

　　With Worksheets("注文データ")
　　　　For Each r In .Range("A2", .Cells(Rows.Count, 1).End(xlUp))
　　　　　　st = r.Value & "_" & r.Offset(, 1).Value
　　　　　　If Not myDic.Exists(st) Then myDic.Add st, CreateObject("Scripting.Dictionary")
　　　　　　s = r.Offset(, 1).Value
　　　　　　If Not myDic(st).Exists(s) Then myDic(st).Add s, 0
　　　　　　　　myDic(st)(s) = myDic(st)(s) + r.Offset(, 2).Value
　　　　Next
　　End With

　　With Worksheets("外注表")
　　　　.Range("C2", .Cells(Rows.Count, 3)).ClearContents ' 数量の列の値を事前に消去
　　　　For Each r In .Range("A2", .Cells(Rows.Count, 1).End(xlUp))
　　　　　　For Each v In Split(r.Offset(, 1), " ")
　　　　　　　　st = r.Value & "_" & v
　　　　　　　　If myDic.Exists(st) Then
　　　　　　　　　　If myDic(st).Exists(v) Then _
　　　　　　　　　　　　r.Offset(, 2).Value = r.Offset(, 2).Value + Val(myDic(st)(v))
　　　　　　　　End If
　　　　　　Next
　　　　　　r.Offset(, 2).Value = IIf(r.Offset(, 2).Value = "", "-", r.Offset(, 2).Value)
　　　　Next
　　End With
　　Set myDic = Nothing
End Sub

ご検証願います。

No.1 回答者： めぐみん_ 回答日時： 2018/11/10 14:25

■シート名：外注表　の　サイズはＡ列として、カラーがＢ列の場合その値は半角スペースで繋がっているのでしょうか？

この回答へのお礼

ご質問頂きありがとうございます。B列のカラーは半角スペースで繋がっております。宜しくお願い致します。

お礼日時：2018/11/10 15:04