使用 VBA 字典根据多个条件对具有相同 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

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

当前代码：

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

1. 现在回到您的第一个表格，在A2 中放置以下公式并向下拖动：

   =SUMIF(Sheet2!C:C,Sheet1!C2,Sheet2!A:A)

---

然后瞧，根据需要。这一切都来自一个简单快捷的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 轻松实现自动化。