I am trying to sort through a couple hundred rows in a workbook to pull information based on progressive keys. First, create a list of all unique names, then for each unique name find all associated product codes, and finally create a list of each quantity of product. What it should look like:
'Name1
'-----product1
'-------------quantity1
'-------------quantity2
'-----product2
'-------------quantity1
'-------------quantity2
'name2
'-----product1
'-------------quantity1
'-------------quantity2
'-----product2
'-------------quantity1
'-------------quantity2
I tried using a dictionary but can't figure out how to get it to return more than the first entry per unique name. This is the code I have so far:
Sub CreateNameList2()
Application.ScreenUpdating = False
Dim wb As Workbook: Set wb = ThisWorkbook
Dim sws As Worksheet: Set sws = wb.Worksheets("Label-Mod Data")
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim AssociateName As String
Dim ColAssociateNames As Integer
Dim ColCurrentLabels As Integer
Dim ColPTSCodes As Integer
Dim ColRegionCodes As Integer
Dim nbRows As Long
Dim iRow As Integer
Dim i As Integer
Dim k As Variant
ColAssociateNames = 8
ColCurrentLabels = 9
ColPTSCodes = 14
ColRegionCodes = 15
nbRows = 155
i = 2
For iRow = 2 To nbRows
AssociateName = sws.Cells(iRow, ColAssociateNames).Value2
If Not dict.Exists(AssociateName) Then
dict.Add Key:=AssociateName, Item:=Array(sws.Cells(i, ColPTSCodes).Value2, sws.Cells(i, ColCurrentLabels).Value2, sws.Cells(i, ColRegionCodes).Value2)
i = i 1
End If
Next iRow
iRow = 2
For Each k In dict.Keys
With sws
.Cells(iRow, 18).Value2 = k
.Cells(iRow, 19).Value2 = dict.Item(k)(0)
.Cells(iRow, 20).Value2 = dict.Item(k)(1)
.Cells(iRow, 21).Value2 = dict.Item(k)(2)
End With
iRow = iRow 1
Next k
Set dict = Nothing
Debug.Print
Application.ScreenUpdating = True
End Sub
Can this be done with a dictionary?
For privacy reasons I can't show the data but I will try to explain it. My raw data comes in 3 columns and varies in number of rows, todays is 155. Column 1 has a name, column 2 has a product ID and column 3 has a quantity. There are currently 48 possible names, 12 possible product ID's and undetermined quantity amounts. Looks Like this:
Name1 | product 3 | 25
Name1 | product 1 | 12
Name5 | product 9 | 171
Name4 | product 3 | 48
Name1 | product 7 | 23
Name42 | product 9 | 9
Name5 | product 1 | 22
Name4 | product 3 | 42
What I need to do is change it to:
Name1 | product 1 | 12
| product 3 | 25
| product 7 | 23
Name4 | product 3 | 90
(combine above quantity with matching name and product)
Name5 | product 1 | 22
| product 9 | 171
Name42 | product 9 | 9
CodePudding user response：
Like this would work:
Sub Tester()
Dim dict As Object, rw As Range, Q, kN, kP
Set dict = CreateObject("scripting.dictionary")
Set rw = Range("A1:C1") 'first row of data
Do While Application.CountA(rw) = 3 'while row data is complete
kN = rw.Cells(1).Value 'name key
kP = rw.Cells(2).Value 'product key
Q = rw.Cells(3).Value 'quantity
'add keys if missing...
If Not dict.exists(kN) Then dict.Add kN, CreateObject("scripting.dictionary")
If Not dict(kN).exists(kP) Then dict(kN).Add kP, 0
dict(kN)(kP) = dict(kN)(kP) Q 'sum quantity for this key combination
Set rw = rw.Offset(1) 'next row
Loop
'output to Immediate pane
For Each kN In dict
Debug.Print "---" & kN & "---"
For Each kP In dict(kN)
Debug.Print " " & kP & " = " & dict(kN)(kP)
Next
Next kN
End Sub
CodePudding user response：
Based on the additional information provided, it looks like you can make use of a composite key comprised of the Name and Product identifiers. Doing so can support a solution that uses an AssociateName-to-nameProductQuantityMap Dictionary where nameProductQuantityMap is also a Dictionary that associates Quantity totals to each Name Product composite key.
Option Explicit
'May need a more elaborate delimiter if "." used in the Names or Products
Const compositeKeyDelimiter As String = "."
Private Type TColumns
Associate As Long
Name As Long
Product As Long
Quantity As Long
End Type
Sub CreateNameList2Answer()
Application.ScreenUpdating = False
Dim wb As Workbook: Set wb = ThisWorkbook
Dim sws As Worksheet: Set sws = wb.Worksheets("Label-Mod Data")
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim AssociateName As String
Dim ColAssociateNames As Integer
Dim ColCurrentLabels As Integer
Dim ColPTSCodes As Integer
Dim ColRegionCodes As Integer
Dim nbRows As Long
Dim iRow As Integer
Dim i As Integer
ColAssociateNames = 8
ColCurrentLabels = 9
ColPTSCodes = 14
ColRegionCodes = 15
nbRows = 155
i = 2
'Modify if these are not mapped to the correct column names
Dim xColumns As TColumns
xColumns.Associate = ColAssociateNames
xColumns.Name = ColCurrentLabels
xColumns.Product = ColPTSCodes
xColumns.Quantity = ColRegionCodes
Dim xAssociateName As Variant
Dim xName As String
Dim xProduct As String
Dim xQuantity As Long
Dim xCompositeKey As String
Dim nameProductQuantityMap As Object
For iRow = 2 To nbRows
AssociateName = sws.Cells(iRow, xColumns.Associate).Value2
xName = sws.Cells(i, xColumns.Name).Value2
xProduct = sws.Cells(i, xColumns.Product).Value2
xQuantity = CLng(sws.Cells(i, xColumns.Quantity).Value2)
xCompositeKey = CreateCompositeKey(xName, xProduct)
If Not dict.Exists(AssociateName) Then
dict.Add Key:=AssociateName, Item:=CreateObject("Scripting.Dictionary")
End If
Set nameProductQuantityMap = dict.Item(AssociateName)
If Not nameProductQuantityMap.Exists(xCompositeKey) Then
nameProductQuantityMap.Add xCompositeKey, 0
End If
nameProductQuantityMap.Item(xCompositeKey) _
= nameProductQuantityMap.Item(xCompositeKey) xQuantity
i = i 1
Next iRow
iRow = 2
Dim xKey As Variant
For Each xAssociateName In dict.Keys
Set nameProductQuantityMap = dict.Item(xAssociateName)
For Each xKey In nameProductQuantityMap
LoadContent sws, iRow, CStr(xAssociateName), _
CStr(xKey), _
nameProductQuantityMap.Item(xKey)
iRow = iRow 1
Next
Next xAssociateName
Set dict = Nothing
Set nameProductQuantityMap = Nothing
Debug.Print
Application.ScreenUpdating = True
End Sub
Private Sub LoadContent(ByVal pWksht As Worksheet, ByVal pRow As Long, _
ByVal pAssociate As String, _
ByVal pCompositeKey As String, _
ByVal pQuantity As Long)
Dim xName As String
Dim xProduct As String
ExtractNameAndProductFromKey pCompositeKey, xName, xProduct
With pWksht
.Cells(pRow, 18).Value2 = pAssociate
.Cells(pRow, 19).Value2 = xName
.Cells(pRow, 20).Value2 = xProduct
.Cells(pRow, 21).Value2 = pQuantity
End With
End Sub
Private Function CreateCompositeKey(ByVal pName As String, ByVal pProduct As String) As String
CreateCompositeKey = pName & compositeKeyDelimiter & pProduct
End Function
Private Sub ExtractNameAndProductFromKey(ByVal pCompositeKey As String, ByRef pOutName As String, ByRef pOutProduct As String)
Dim xKeyParts As Variant
xKeyParts = Split(pCompositeKey, compositeKeyDelimiter)
pOutName = xKeyParts(0)
pOutProduct = xKeyParts(1)
End Sub