代码之家 › 专栏 › 技术社区 › RugsKid

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

vlookup dictionary excel vba

RugsKid · 技术社区 · 7 年前

我正在尝试使用字典进行查找。我得到了一些不正确的结果,因为我查找的数据重复。以下是我查找的“公式版本”:

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

问题是,在Subs摘要工作表上,“合同”(第I列)可以有多行具有相同合同(并且VLookup只回拉找到合同的第一行)。我想通过字典执行查找,当出现重复契约时,对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

非常感谢您的任何意见-我对字典和VBA一般来说都是新手,因此可能是我现有的代码存在另一个问题/效率低下。据我所知,它运行时没有错误,并检索到正确的值,但重复的值除外。

干杯

1 回复 | 直到 6 年前

RugsKid 7 年前

我能够通过调整/添加这一部分来调整我上面发布的代码:

 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

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 以

推荐文章