Question

我正在尝试使用字典来执行查找。我得到一些不正确的结果，因为我查找的数据重复。下面是我查找的“公式版本”：

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

问题在于，在“订阅摘要”工作表中，“合同”（第一列）可以有多行具有相同的合同（并且Vloookup仅撤回它找到合同的第一行）。我想通过字典执行查找，当发生重复的合同时，要对P列中的值进行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，但根本没有处理重复项。我正在尝试编码一个检查，如果密钥（在第一列中）已经存在于字典中，如果是，则将列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最终没有工作，因为＆＃34; Orders＆＃34;工作表以及＆＃34;子摘要＆＃34;工作表。也许有一种方法可以仅使用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

谢谢大家！下一个我 .Range（＆＃34; CM2：CM＆＃34;＆amp; lastRow）.Value = y2＆＃39;＆lt;＆lt;将输出放在工作表上

结束

加载对重复键求和的VBA词典

1 个答案: