重複するキーを合計するVBAディクショナリをロードする

Question

辞書を使用してルックアップを実行しようとしています。私は検索するデータに重複があるため、いくつかの不正確な結果を得ています。以下は私の検索の「公式バージョン」です：

=IFERROR(VLOOKUP([@[Contract]],'Subs Summary'!I:P,8,FALSE),0) 

問題が潜水概要ワークシート上で、「契約」（列I）は、同じ契約に複数の行を持つことができるということです（とVloookupだけ引っ張ります契約を見つける最初の行を戻します）。私はディクショナリを介して検索を実行したい、重複したコントラクトが発生した場合は、最初のインスタンス/行を取得するだけではなく、列Pの値をSUMにSUMします。以下は

辞書のロードとルックアップのための私の現在のコードです：

Dim x, x2, y, y2() 
Dim i As Long 
Dim dict As Object 
Dim LastRowTwo As Long, shtOrders As Worksheet, shtReport As Worksheet 

Set shtOrders = Worksheets("Orders") 
Set shtReport = Worksheets("Subs Summary") 
Set dict = CreateObject("Scripting.Dictionary") 

'get the lookup dictionary from Report 
With shtReport 
    lastRow = .Range("A" & Rows.Count).End(xlUp).Row 
    x = .Range("I2:I" & lastRow).Value 
    x2 = .Range("P2:P" & lastRow).Value 
    For i = 1 To UBound(x, 1) 
     dict.Item(x(i, 1)) = x2(i, 1) 
    Next i 
End With 

'map the values 
With shtOrders 
    lastRow = .Range("A" & Rows.Count).End(xlUp).Row 
    y = .Range("C2:C" & lastRow).Value  'looks up to this range 
    ReDim y2(1 To UBound(y, 1), 1 To 1)  '<< size the output array 
    For i = 1 To UBound(y, 1) 
     If dict.exists(y(i, 1)) Then 
      y2(i, 1) = dict(y(i, 1)) 
     Else 
      y2(i, 1) = "0" 
     End If 
    Next i 
    .Range("CM2:CM" & lastRow).Value = y2  '<< place the output on the sheet 
End With 

このコードは（私は信じて）正しくVLOOKUPを実行するが、すべての重複を処理せずにされています。私はキー（列Iの）がすでに辞書に存在するかどうかチェックし、そうであれば、列Pの行の値をその契約/キーの既存の列Pの値に合計します。ルックアップ・ページには、キー/コントラクトに4行（サブ・サマリー）があることがよくあります。

すべての入力を非常に感謝しています - 私はかなり辞書やVBAの一般的なので、私の既存のコードは別の問題/非効率性がある可能性があります。それはエラーなく実行され、私が知る限り重複を除いて正しい値を検索します。

乾杯！

Answer 1

私はこの部分を追加/調整して掲載コードの上に私を適応させることができました：「受注」ワークシートだけでなく、「潜水の両方に重複があったので

If Not dict.exists(x(i, 1)) Then 
    dict.Add x(i, 1), x2(i, 1) 
Else 
    dict.Item(x(i, 1)) = CDbl(dict.Item(x(i, 1))) + CDbl(x2(i, 1)) 
End If 
Next i 

SUMIFSは作業を終了していませんでした要約 "ワークシート。 SUMIFSだけを使ってこれを行う方法があるかもしれませんが、その中のコード（以下に示す）は全体的にうまくいきます。

Dim x, x2, y, y2() 
Dim i As Long 
Dim dict As Object 
Dim LastRowTwo As Long, shtOrders As Worksheet, shtReport As Worksheet 

Set shtOrders = Worksheets("Orders") 
Set shtReport = Worksheets("Subs Summary") 
Set dict = CreateObject("Scripting.Dictionary") 

'get the lookup dictionary from Report 
With shtReport 
    lastRow = .Range("A" & Rows.Count).End(xlUp).Row 
    x = .Range("I2:I" & lastRow).Value 
    x2 = .Range("P2:P" & lastRow).Value 
    For i = 1 To UBound(x, 1) 

If Not dict.exists(x(i, 1)) Then 
    dict.Add x(i, 1), x2(i, 1) 
Else 
    dict.Item(x(i, 1)) = CDbl(dict.Item(x(i, 1))) + CDbl(x2(i, 1)) 
End If 
Next i 

End With 

'map the values 
With shtOrders 
    lastRow = .Range("A" & Rows.Count).End(xlUp).Row 
    y = .Range("C2:C" & lastRow).Value 'looks up to this range 
    ReDim y2(1 To UBound(y, 1), 1 To 1) '<< size the output array 
    For i = 1 To UBound(y, 1) 
     If dict.exists(y(i, 1)) Then 
      y2(i, 1) = dict(y(i, 1)) 
     Else 
      y2(i, 1) = "0" 
     End If 

ありがとうございます！ 次のI .Range（ "CM2：CM" & LASTROW）.Valueの= Y2 "