加載一個總和重複鍵的VBA詞典

我想用字典來執行查找。由於我查找的數據有重複，因此我得到了一些不正確的結果。下面是我查找的「公式版」：加載一個總和重複鍵的VBA詞典

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

的問題是，在替補總結工作，「合同」（I欄）可以有多個行具有相同的合同（和Vloookup只拉回到找到合同的第一行）。我想通過字典執行查找，當發生重複契約時，對列P中的值進行求和（而不是僅檢索第一個實例/行）。

下面是我的字典加載和查詢當前代碼：

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行（Subs Summary）。

任何輸入都非常感謝 - 我對字典和VBA一般都比較陌生，所以可能是我現有的代碼有另一個問題/效率低下。它確實運行沒有錯誤，並根據我所知可以檢索除重複項之外的正確值。

乾杯！

來源

2017-09-14 RugsKid

問題標題是不明確的：一個字典**通過定義**不會有重複的密鑰。但是，我明白你的意思。你不想要一個SUMIF嗎？ –

@ Mat'sMug你是完全正確的 - 任何建議更合適的標題？是的，我認爲SUMIF（針對我所描述的情況），但我不清楚「檢查合約是否重複應該發生」以及使用什麼語法 – RugsKid

瞭解SUMIF和SUMIFS是如何工作的。你可以不用任何代碼就可以做到 –

我能適應我上面貼通過調節碼/添加此部分：

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）。價值= Y2'< <就位在片結束的輸出與

來源

2017-09-14 20:10:43 RugsKid

加載一個總和重複鍵的VBA詞典

回答

相關問題