根据多个条件VBA合并和求和值

Question

我有 3 个不同的数据模板用于各种活动。我需要整合我在这 3 个模板中收到的数据，并且正在寻找一种更通用的方法，但我也可以复制相同的宏并调整参数以适应所有 3 个模板，这样我就可以有一个用户表单并询问用户他们使用什么模板，然后我可以触发 3 个宏之一。我在Dictionary or Collection方面不是很有经验，所以不太确定我是否使用了正确的方法。我采用了字典方法，因为我想检查键是否存在，因为我在编译后正在寻找唯一的数据。我在字典方法中使用了字典，因为我有一列具有订单号，并且我有多个产品可以复制不同数量。我需要每个订单号的唯一产品，我需要对重复产品的数量求和。工作表中还有其他数据，我需要为每个产品添加回来，所以这意味着在我的字典中，我必须在产品数量总和之后连接所有列。我过去做过对数据进行排序并使用反向循环并添加数量，同时还映射要删除的重复项，但我想尝试学习字典和集合，看看是否有任何速度提高，因为数据往往超过 100k 行和 20 列>所以我认为这将是一个更好的方法。我是字典的新手，所以任何指导将不胜感激。

下面的问题是我似乎无法找出字典中的数据出错的地方，所以我似乎没有得到正确的输出。数量已关闭，并且由于某种原因，它在最后一行之后写入其他数据。

示例数据：

Order NO | OtherData1 | OtherData2 | Product | Qty | OtherData3 | OtherData4 | OtherData5|>20col
10001    | 100        | GB         |111111111| 10  | 900-001    | UK1        | Descr     |
10001    | 100        | GB         |222222222| 100 | 900-001    | UK1        | Descr     |
10001    | 100        | GB         |111111111| 15  | 900-001    | UK1        | Descr     |
20001    | 100        | GB         |333333333| 25  | 900-001    | UK1        | Descr     |
20001    | 100        | GB         |111111111| 20  | 900-001    | UK1        | Descr     |
10001    | 100        | GB         |444444444| 30  | 900-001    | UK1        | Descr     |
10001    | 100        | GB         |555555555| 50  | 900-001    | UK1        | Descr     |

期望输出：

Order NO | OtherData1 | OtherData2 | Product | Qty | OtherData3 | OtherData4 | OtherData5|>20col
10001    | 100        | GB         |111111111| 25  | 900-001    | UK1        | Descr     |
10001    | 100        | GB         |222222222| 100 | 900-001    | UK1        | Descr     |
20001    | 100        | GB         |333333333| 25  | 900-001    | UK1        | Descr     |
20001    | 100        | GB         |111111111| 20  | 900-001    | UK1        | Descr     |
10001    | 100        | GB         |444444444| 30  | 900-001    | UK1        | Descr     |
10001    | 100        | GB         |555555555| 50  | 900-001    | UK1        | Descr     |

这是我的代码：

Sub AddDuplicates()
Dim dic As Object
Dim dic2 As Object
Dim Contents As Variant
Dim ParentKeys As Variant
Dim ChildKeys As Variant
Dim r As Long, r2 As Long
Dim LastR As Long
' Create "parent" Dictionary.  Each key in the parent Dictionary will be a disntict
' Code value, and each item will be a "child" dictionary.  For these "children"
' Dictionaries, each key will be a distinct Product value, and each item will be the
' sum of the Quantity column for that Code - Product combination
Set dic = CreateObject("Scripting.Dictionary")
dic.CompareMode = vbTextCompare
' Dump contents of worksheet into array
With ActiveSheet
LastR = FindLastRow(ActiveSheet, 3, 21) '.Cells(.Rows.Count, 1).End(xlUp).Row
Contents = .Range("C17:U" & LastR).value
End With
' Loop through the array
For r = 1 To UBound(Contents, 1)
' If the current code matches a key in the parent Dictionary, then set dic2 equal
' to the "child" Dictionary for that key
If dic.exists(Contents(r, 1)) Then
Set dic2 = dic.Item(Contents(r, 1))
' If the current Product matches a key in the child Dictionary, then set the
' item for that key to the value of the item now plus the value of the current
' Quantity
If dic2.exists(Contents(r, 3)) Then
dic2.Item(Contents(r, 3)) = dic2.Item(Contents(r, 3)) + Contents(r, 4)

' If the current Product does not match a key in the child Dictionary, then set
' add the key, with item being the amount of the current Quantity
Else
dic2.Add Contents(r, 3), Contents(r, 4)
End If
' If the current code does not match a key in the parent Dictionary, then instantiate
' dic2 as a new Dictionary, and add an item (Quantity) using the current Product as
' the Key.  Then, add that child Dictionary as an item in the parent Dictionary, using
' the current Code as the key
Else
Set dic2 = CreateObject("Scripting.Dictionary")
dic2.CompareMode = vbTextCompare
dic2.Add Contents(r, 3), Contents(r, 4) 'Contents(r, 1),
dic.Add Contents(r, 1), dic2
End If
Next
Dim i As Long
Dim tempVar As Variant
For r = 1 To UBound(Contents, 1)
If dic.exists(Contents(r, 1)) Then Set dic2 = dic.Item(Contents(r, 1))
If dic2.exists(Contents(r, 3)) Then
For i = 1 To 19
If i <> 4 Then
tempVar = tempVar & "|" & Contents(r, i)
'dic2.Item(Contents(r, 3)) = dic2.Item(Contents(r, i))
Else
If tempVar <> Left(dic2.Item(Contents(r, 3)), Len(tempVar)) Then
tempVar = tempVar & "|" & dic2.Item(Contents(r, 3))
'dic2.Item(Contents(r, 3)) = dic2.Item(Contents(r, i))
Else
'already in the right format now duplicates exit
tempVar = Empty
Exit For
End If
End If
'Debug.Print tempVar
Next i
End If
If tempVar <> vbNullString Then
dic2.Item(Contents(r, 3)) = tempVar
'Debug.Print dic2.Item(Contents(r, 3))
tempVar = Empty
End If
Next r

Worksheets.Add    'for testing to delete after
[a1:c1].value = Array("Code", "Product", "Qty")    'for testing to delete after
' Dump the keys of the parent Dictionary in an array
ParentKeys = dic.keys
For r = 0 To UBound(ParentKeys)
' Write the parent Dictionary's keys (i.e., the distinct Code values) to the worksheet
LastR = FindLastRow(ActiveSheet, 1, 21)
Set dic2 = dic.Item(ParentKeys(r))
Range("B" & LastR).Resize(UBound(dic2.keys) + 1, 1).value = Application.Transpose(dic2.keys)
Range("C" & LastR).Resize(UBound(dic2.keys) + 1, 1).value = Application.Transpose(dic2.items)
Dim x As Long
Dim dictCount As Long
dictCount = dic2.Count
Dim maxRecords As Long
maxRecords = 999
For x = 1 To WorksheetFunction.RoundUp(dic2.Count / 999, 0)
LastR = ActiveSheet.Range("A" & ActiveSheet.Rows.Count).End(xlUp).Row + 1
If UBound(dic2.keys) > 999 Then
If dictCount > 999 Then
dictCount = dictCount - 999
Else
maxRecords = dictCount
End If
Range("A" & LastR).Resize(maxRecords, 1).value = Application.Transpose(ParentKeys(r) & "-" & x)
Else
Range("A" & LastR).Resize(UBound(dic2.keys) + 1, 1).value = Application.Transpose(ParentKeys(r))
End If
Next x
Next r

' Destroy object variables
Set dic2 = Nothing
Set dic = Nothing
MsgBox "Done"
End Sub

Answer 1

试试这段代码

Sub Test()
Dim a, ws As Worksheet, sh As Worksheet, txt As String, i As Long, ii As Long
Set ws = ThisWorkbook.Worksheets("Sheet1")
Set sh = ThisWorkbook.Worksheets("Sheet2")
a = ws.Range("A1").CurrentRegion.Value
With CreateObject("Scripting.Dictionary")
For i = 2 To UBound(a, 1)
txt = Join(Array(a(i, 1), a(i, 4)), Chr(2))
If Not .Exists(txt) Then
.Item(txt) = .Count + 1
For ii = 1 To UBound(a, 2)
a(.Count, ii) = a(i, ii)
Next ii
Else
a(.Item(txt), 5) = a(.Item(txt), 5) + a(i, 5)
End If
Next i
i = .Count
End With
With sh.Range("A1")
.Resize(1, UBound(a, 2)).Value = ws.Range("A1").Resize(1, UBound(a, 2)).Value
.Resize(1, UBound(a, 2)).Font.Bold = True
.Offset(1).Resize(i, UBound(a, 2)) = a
.Parent.Columns.AutoFit
End With
End Sub

Answer 2

您可以使用单个字典和组合键 订单~产品。使用字典对数量求和。在第一次出现键时将完整记录复制到输出表，并在扫描所有数据后重新访问输出以更新数量。

Option Explicit
Sub SumDuplicates()
Dim dictQu As Object
Dim wb As Workbook, ws As Worksheet, wsOut As Worksheet
Dim iLastRow As Long, iOutRow As Long, iRow As Long
Dim sOrder As String, sProduct As String, sKey As String
Dim nQu As Single
Set dictQu = CreateObject("Scripting.Dictionary")
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet1") ' Sample Data
Set wsOut = wb.Sheets("Sheet2") ' Output
iLastRow = ws.Cells(Rows.Count, "C").End(xlUp).Row
iOutRow = 2
For iRow = 17 To iLastRow
sOrder = ws.Cells(iRow, "C")
sProduct = ws.Cells(iRow, "F")
nQu = ws.Cells(iRow, "G")
' create composite key
sKey = sOrder & "~" & sProduct
If dictQu.exists(sKey) Then
dictQu(sKey) = dictQu(sKey) + nQu
Else
dictQu(sKey) = nQu
' copy col C to W to output
ws.Cells(iRow, 3).Resize(1, 21).Copy wsOut.Cells(iOutRow, 3)
iOutRow = iOutRow + 1
End If
Next
' update total
With wsOut
For iRow = 2 To iOutRow - 1
sOrder = .Cells(iRow, "C")
sProduct = .Cells(iRow, "F")
sKey = sOrder & "~" & sProduct
.Cells(iRow, "G") = dictQu(sKey)
Next
End With
MsgBox "OK"
End Sub