I have 3 different data templates that are used for various activities. I need to consolidate the data that I receive in this 3 templates and was looking at a more universal approach but I can also copy same macro and tweak the parameters to fit all 3 templates so that shouldn't be much work I can have a user form and ask user what template they use and then I can fire one of the 3 macros. I am not very experienced in Dictionary or Collection so not too sure if for may case I used the right one. I went with a dictionary approach because I wanted to check for if key exists as I am looking for unique data after compilations. I used a dictionary in dictionary approach as I have one column that has a order number and in that I have multiple products that can be duplicates with different quantities. I require unique products for each order number and the duplicate products I need to sum their qty's. There is also other data in the sheet that I need to add back for each product so this will mean in my dictionary I had to join all columns after the sum the product qty. I have done in the past where I order the data and use reverse loop and add the qty while also mapping the duplicates to delete but I wanted to try and learn dictionary and collection see if there is any speed increase as the data tends to be over 100k rows and > 20 cols so I thought this would be a better approach. I am new to dictionary so any guidance will be much appreciated.
The problem with the below is that I cannot seem to find out where the data in the dictionary is going wrong so I don't seem to get the right output. The qty's off and also it's writing other data after the last row for some reason.
Sample Data:
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 |
Desired output:
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 |
Here is my code:
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
Try this code
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