使用VBA DIctionary根据多个标准对具有相同ID的行进行求和

Question

我正在尝试（目前通过字典）来解决以下示例数据：

Sales Amount     Product       ID        Count
    100           apple      123ABC       1
    50            apple      456DEF       2
    50            apple      456DEF       2
    200           orange     456DEF       2
    200           orange     456DEF       2
    900           tomato     789GHI       1
    75            orange     999PPP       2
    25            apple      999PPP       2
    25            apple      999PPP       2

我需要做的是：对于count> 1的任何行，将所有共享ID但具有不同产品的行的销售额相加。然后我想在Sales Amount列中的现有值上写入和值。最终结果如下所示：

  Sales Amount   Product       ID        Count
    100           apple      123ABC       1
    250           apple      456DEF       2
    250           apple      456DEF       2
    250           orange     456DEF       2
    250           orange     456DEF       2
    900           tomato     789GHI       1
    100           orange     999PPP       2
    100           apple      999PPP       2
    100           apple      999PPP       2

棘手的部分是我只想每个Sales Amount使用product一次。所以例如ID 456DEF，我只想为苹果添加50，为橙添加200。我当前的代码（见下文）是对每个ID的Sales Amount列中的所有值求和。因此，假设相同的示例ID 456DEF，我的代码在每行输出500的Sales Amount作为ID（200 + 200 + 50 + 50）。

现行代码：

Sub WontWorkYet

Dim x, x2, y, y2()
Dim i As Long
Dim dict As Object
Dim LastRowForDict As Long, LastRowResult As Long, shtSource As      Worksheet, shtResult As Worksheet
Dim p As Long


Set dict = CreateObject("Scripting.Dictionary")
Set ws = Worksheets("Sheet1")

With ws

    LastRowForDict = .Range("A" & Rows.Count).End(xlUp).Row

For p = 1 To LastRowForDict

    If ws.Cells(p, 4) > 1 Then               'checks if count column for unique products is >1

    x = .Range("C1:C" & LastRowForDict).Value
    x2 = .Range("A1:A" & LastRowForDict).Value


        'If key exists already ADD new value (SUM them)


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

End If
Next p


End With


'map the values
  With ws
    LastRowResult = .Range("A" & Rows.Count).End(xlUp).Row
    y = .Range("C2:C" & LastRowResult).Value    'looks up to this range
  y2 = .Range("A2:A" & LastRowForDict).Value   'Sizes the output array without a Re-Dim which allows existing values to not be wiped out in column CL


    For i = 1 To UBound(y, 1)
        If dict.exists(y(i, 1)) Then
            y2(i, 1) = dict(y(i, 1))
       Else


        End If
    Next i
    .Range("A2:A" & LastRowResult).Value = y2  '<< place the output on the sheet
End With


End Sub

我的想法是可能将ID与Product连接起来，然后删除这一行，它总结了现有的密钥：dict.Item(x(p, 1)) = CDbl(dict.Item(x(p, 1))) + CDbl(x2(p, 1))。这会将值正确地存储（我相信）在字典中，但后来我试图找到一种方法来完成整个过程，方法是将每个ID的存储量相加并将它们正确地写入工作表。

我知道可以使用数组公式来解决这个问题，但我使用的数据集很大，数组公式太慢了。

在此先感谢您的帮助！

Answer 1

首先，尝试这个公式。还是太慢了吗？

=SUMPRODUCT($A$2:$A$10/COUNTIFS($B$2:$B$10,$B$2:$B$10,$C$2:$C$10,$C$2:$C$10),--($C$2:$C$10=C2))

其次，这可以是一个简单的操作，帮助删除重复。试试这个：

1. 将所有数据粘贴到sheet2中，选择整个范围，然后单击“数据”>“删除重复项”>“确定”

您在sheet2中的数据现在如下所示：

Sales Amount    Product ID  Count
100    apple    123ABC      1
50     apple    456DEF      2
200    orange   456DEF      2
900    tomato   789GHI      1
75     orange   999PPP      2
25     apple    999PPP      2

2. 现在回到你的第一张桌子，在A2放置以下公式并向下拖动： = SUMIF（！Sheet2的C：C，Sheet 1中C2，Sheet2的一个：！A）

---

Et voila，视需要而定。所有这一切都来自简单快速的SUMIF配方。

Sales Amount    Product ID  Count
100     apple   123ABC      1
250     apple   456DEF      2
250     apple   456DEF      2
250     orange  456DEF      2
250     orange  456DEF      2
900     tomato  789GHI      1
100     orange  999PPP      2
100     apple   999PPP      2
100     apple   999PPP      2

使用VBA也可以轻松实现这样一个简单的过程。