I'm hoping someone can help with the VBA code.
I'm trying to populate all members in an ownership chain. The relationships are like below:
So basically, B owns A and C. A owns D. C owns E and F.
The outcome I'm expecting is B: A, C, D, E, F
Thank you so much!
I am not sure how to write the VBA code.
I would suggest you to use the Microsoft Scripting Runtime library to be able to use the Dictionary structure.
Here is the vba code I would use then:
Sub ownership_chain()
Dim dic As New Scripting.Dictionary
Dim iRow As Integer
Dim entity As String
Dim owner As String
Dim key As Variant
Dim key2 As Variant
Dim res As New Scripting.Dictionary
Dim count As Integer
For iRow = 2 To 6 ' to adapt to your file
entity = Cells(iRow, 1).Value
owner = Cells(iRow, 2).Value
If Not dic.Exists(owner) Then
dic.Add owner, New Collection
End If
dic(owner).Add entity
Next iRow
For Each key In dic
res(key) = 0
Next key
For Each key In dic
For Each key2 In dic(key)
res(key2) = 0
Next key2
Next key
count = 0
For Each key In res
If count = 0 Then
display = display & key & ": "
Else:
display = display & key & ", "
End If
count = count + 1
Next key
Debug.Print Left$(display, Len(display) - 2)
End Sub
Hope this helps
Related
Here is what I am trying to accomplish:
I have an ID in Column DA. I have a product in Column CB. I want to count the number of unique products for each ID (ID can have multiple lines). I then want to write the number of unique products to a new column (DB).
My logic was to write two dictionaries. The "main" dictionary would be keyed to the ID and the second dictionary would be keyed to my products. In the main dictionary, if the key exists I would retrieve the item into a dict object, if it doesn't exist then I'd re-write the main dictionary.
After this, I was thinking of using .count function to tell me how many unique values existed for each ID.
I have been trying to adapt some code to fit my needs. Here is what I have currently:
Sub Find_Unique_Product_Number()
Dim LastRow As Long
LastRow = Worksheets("Orders").Range("A" & Rows.Count).End(xlUp).Row
adata = Worksheets("Orders").Range("A1:DB" & LastRow)
Set dicTwoProds = CreateObject("Scripting.Dictionary") 'Late binding creation of dictionary
For LastRow = LBound(adata, 1) To UBound(adata, 1)
sKey1 = adata(LastRow, 80)
If Not dicTwoProds.Exists(sKey) Then
Set dicItem = CreateObject("Scripting.Dictionary")
dicTwoProds.Add sKey1, aItem
sKey1 = Worksheets("Orders").Range("CB2:CB" & LastRow) 'Product
dicTwoProdsItem.Add sKey1, ""
Else
Set dicItem = dicTwoProd.Item(sKey)
sKey2 = Worksheets("Orders").Range("CB2:CB" & LastRow) 'Product
If Not dicItem.Exists(sKey2) Then
dicItem.Add sKey2, ""
dicTwoProds.Item(sKey) = aItem
End If
End If
Next
End Sub
Currently this code throws an "object required" error on this line: dicTwoProdsItem.Add sKey1, ""
I am guessing part of my issue is how I am using .range on the sKey lines? I am unsure of how that syntax should be.
I am not sure how writing the .count results to the sheet would work at all yet.
I do have an array formula that does what I need which is this:
'=SUM(IF(DA5=DA2:DA100,1/ (COUNTIFS(DA2:DA100,DA5,CB2:CB100,CB2:CB100)),0))
The formula is extremely slow which is part of the reason I wanted to use dictionaries. If the dictionary solution does not work, I would be interested in assistance with the syntax for using VBA to place the array formula into Column DB on my worksheet.
All data is on the same worksheet in the described scenario.
Cheers!
You can use a single Dictionary to count the number of unique products for each ID.
The trick is to concatenate the id with the product to create a unique key:
Dim dict As Object, lastRow As Long, r As Long, ids(), products(), dupIds()
Set dict = CreateObject("Scripting.Dictionary")
lastRow = Worksheets("Orders").Cells(Rows.Count, 1).End(xlUp).Row
ids = Worksheets("Orders").Range("DA2:DA" & lastRow).Value
products = Worksheets("Orders").Range("CB2:CB" & lastRow).Value
' map the id to each unique id/product '
For r = LBound(ids) To UBound(ids)
dict(ids(r, 1) & products(r, 1)) = CStr(ids(r, 1))
Next
' map the count of products to each unique id '
dupIds = dict.Items
dict.RemoveAll
For r = LBound(dupIds) To UBound(dupIds)
dict(dupIds(r)) = dict(dupIds(r)) + 1
Next
' build the column holding the count of products '
For r = LBound(ids) To UBound(ids)
products(r, 1) = dict(CStr(ids(r, 1)))
Next
Worksheets("Orders").Range("DB2:DB" & lastRow).Value = products
If I'm understanding you correctly something like this should work.
(Simplified for a 2-column dataset)
Sub Find_Unique_Product_Number()
Dim dict As Object, i As Long, id, prod, adata, k, k2
Dim rngDest As Range
Set dict = CreateObject("Scripting.Dictionary")
With Worksheets("Orders")
adata = Worksheets("Orders").Range("A1:B" & _
.Cells(.Rows.Count, 1).End(xlUp).Row).Value
End With
For i = LBound(adata, 1) To UBound(adata, 1)
id = adata(i, 1)
prod = adata(i, 2)
If Len(id) > 0 And Len(prod) > 0 Then
'New id? Add as key with empty dictionary
If Not dict.exists(id) Then dict.Add id, CreateObject("Scripting.Dictionary")
'increment the count for this combination
dict(id)(prod) = dict(id)(prod) + 1
End If
Next
'EDIT: output the counts
Set rngDest = Worksheets("Summary").Range("A2")
For Each k In dict.keys
For Each k2 In dict(k).keys
rngDest.Resize(1, 3).Value = Array(k, k2, dict(k)(k2))
Set rngDest = rngDest.Offset(1, 0)
Next k2
Next
End Sub
I have an application for which I am currently using a dictionary object (specifically, it's a dictionary of dictionaries of dictionaries, so each lookup has three steps, if that makes any sense!). I do a large number of lookups on these dictionaries and multiply the results together.
The problem is that in the previous version of the application, I used the VLookup function to accomplish this functionality, and it would error out when I would try to look up a key that didn't exist. Now, it returns a "Empty", which Excel is happy to multiply by whatever I already had and return a zero. This is hard to track, and I'd very much prefer for it to return an error like before.
Is there something I can change to get it to return the error like it would with a VLookup, or do I need to create a new class module to do this? A class module would likely require me to re-write a large amount of code, which I'd like to avoid (there are hundreds of lookups I would have to update in the code).
Thanks.
Here is some of my code:
This is the module I use to load in all the tables to the dictionary:
Sub LoadFactorsAndBaseRates()
Dim t As Double
t = Timer
Dim n As Name
Dim TempArray()
Dim dict1 As Dictionary
Dim dict2 As Dictionary
Dim i As Integer
Dim j As Integer
For Each n In ThisWorkbook.Names
If InStr(1, n.RefersTo, "#") <> 0 Or InStr(1, n.RefersTo, "\") Then GoTo skipname
If Not FactorLookup.Exists(n.Name) And n.RefersToRange.Parent.Name <> "Rate Matrix" And InStr(1, n.Name, "Print") = 0 And InStr(1, n.Name, "FilterDatabase") = 0 And n.Name <> "Policies" Then
Set dict1 = New Dictionary
On Error GoTo err1
TempArray = n.RefersToRange.Value
For j = 1 To n.RefersToRange.Columns.Count
On Error Resume Next
Set dict2 = New Dictionary
For i = 1 To UBound(TempArray, 1)
dict2.Add TempArray(i, 1), TempArray(i, j)
Next i
dict1.Add j, dict2
Next j
Erase TempArray
FactorLookup.Add n.Name, dict1
End If
skipname:
Next n
Exit Sub
err1:
If Err.number = 1004 Then Resume skipname
End Sub
And here is a sample of the lookup code:
CoverageColumn = 2
'Base Rate
Temp = FactorLookup("Base_Rates")(CoverageColumn)(State & "_" & Company & "_" & Terr)
If Vehicle <> "Snowmobile" Then
'Class 1
x = FactorLookup("Class1")(CoverageColumn)(State & "_" & Company & "_" & Class1)
Temp = xRound(Temp * x, 1)
'Class 2
x = FactorLookup("Class2")(CoverageColumn)(State & "_" & Company & "_" & Class2)
Temp = xRound(Temp * x, 1)
'Class 3
x = FactorLookup("Class3")(CoverageColumn)(State & "_" & Company & "_" & Class3)
Temp = xRound(Temp * x, 1)
'Class 4
x = FactorLookup("Class4")(CoverageColumn)(State & "_" & Company & "_" & Class4)
Temp = xRound(Temp * x, 1)
The code is basically just a bunch of pages of this: look up, multiply, round to the nearest tenth, repeat. Occasionally, there's a step where we add instead of multiplying.
The xRound function adds 0.0000001 and then uses the Round function to round to the indicated number of decimal places (to account for the weirdness of the Excel VBA round function).
You need to create a function to "wrap" your top-level dictionary so you can call it with the three "keys" and get back an error value if that combination doesn't exist.
Function DoFactorLookup(k1, k2, k3) As Variant
Dim d, d2, rv
rv = CVErr(xlErrNA) ' #N/A error value
If FactorLookup.exists(k1) Then
Set d = FactorLookup(k1)
If d.exists(k2) Then
Set d2 = d(k2)
If d2.exists(k3) Then
rv = d2(k3)
End If
End If
End If
DoFactorLookup = rv
End Function
I am trying to remove items from the dictionary which are already selected from the comboboxes. I have a following code but i dont know what the problem is.It gives me an object required error at d2("v" & cbnr).Remove (ss).
a is an Array.
Sub cb_pop2(cbnr As Integer)
Dim i, j As Integer
Dim d2 as object
Dim ss as string
Set d2 = CreateObject("Scripting.Dictionary")
d2("v" & cbnr) = a
For i = cbnr To 5
UserForm1.Controls("ComboBox" & i).Clear
For j = cbnr To i
ss = UserForm1.Controls("ComboBox" & j - 1).Value
d2("v" & cbnr).Remove (ss)
Next j
UserForm1.Controls("ComboBox" & i).List = d2("v" & cbnr).keys
UserForm1.Controls("ComboBox" & i).ListIndex = 0
Next i
End Sub
This is an example of using dictionary in VBA
Sub TestDictionary()
Set dict = CreateObject("Scripting.Dictionary")
For x = 1 To 5
Key = "Start" & x
Value = 0 + x
If Not dict.Exists(Key) Then
dict.Add Key, Value
End If
Next x
For Each k In dict.keys
MsgBox (dict(k))
Next
If dict.Exists(Key) Then
dict.Remove Key
Else
'You can put here a code to show errors
End If
End Sub
I suggest you to use an If-Then to check "Key" before adding/removing so you will able to intercept errors depending by "wrong Key" or "not present Key"
I'm working with a rather large dataset (>100,000 rows) and trying to compare two lists to figure out which items in the new list are not already in the master list. In other words I want to find the new unique items.
I have some VBA code that uses vlookup and arrays that works, but bombs out when the arrays get too big (~70,000). So I've turned to collections. However I'm having difficulty searching the collections using vlookup or match.
Sub find_uniqueIDs()
Dim a As Long
Dim n As Long
Dim m As Variant
Dim oldnum As Long
Dim oldIDs As Variant
Dim oldcoll As New Collection
Dim newnum As Long
Dim newIDs As Variant
Dim newcoll As New Collection
oldnum = 75000
oldIDs = Range("A1", Range("A" & oldnum))
newnum = 45000 + 3
newIDs = Range("G3", Range("G" & newnum))
'Using arrays to search, but bombs out when oldnum or newnum are ~70000
For n = 1 To newnum - 3
m = Application.VLookup(newIDs(n, 1), oldIDs, 1, False)
If IsError(m) Then Range("E100000").End(xlUp).Offset(1, 0) = newIDs(n, 1)
Next n
'Using collections to search
For n = 1 To oldnum
On Error Resume Next
oldcoll.Add oldIDs(n, 1)
On Error GoTo 0
Next n
For m = 1 To newnum
On Error Resume Next
newcoll.Add newIDs(m, 1)
On Error GoTo 0
Next m
'This bit of code doesn't work
For a = 1 To newcoll.Count
If Application.VLookup(newcoll(a), oldcoll, 1, False) = "#N/A" Then _
Range("E100000").End(xlUp).Offset(1, 0) = newcoll(a)
Next a
End Sub
Any ideas how I can determine whether a particular item is in the master list using collections?
Here is a short sub demonstrating some of the scripting dictionary methods.
Sub list_New_Unique()
Dim dMASTER As Object, dNEW As Object, k As Variant
Dim v As Long, vVALs() As Variant, vNEWs() As Variant
Debug.Print "Start: " & Timer
Set dMASTER = CreateObject("Scripting.Dictionary")
Set dNEW = CreateObject("Scripting.Dictionary")
dMASTER.comparemode = vbTextCompare
dNEW.comparemode = vbTextCompare
With Worksheets("Sheet7")
vVALs = .Range("A2:A100000").Value2
vNEWs = .Range("C2:C100000").Value2
End With
'populate the dMASTER values
For v = LBound(vVALs, 1) To UBound(vVALs, 1)
dMASTER.Add Key:=vVALs(v, 1), Item:=vVALs(v, 1)
Next v
'only populate dNEW with items not found in dMASTER
For v = LBound(vNEWs, 1) To UBound(vNEWs, 1)
If Not dMASTER.exists(vNEWs(v, 1)) Then
If Not dNEW.exists(vNEWs(v, 1)) Then _
dNEW.Add Key:=vNEWs(v, 1), Item:=vNEWs(v, 1)
End If
Next v
Debug.Print dNEW.Count
For Each k In dNEW.keys
'Debug.Print k
Next k
Debug.Print "End: " & Timer
dNEW.RemoveAll: Set dNEW = Nothing
dMASTER.RemoveAll: Set dMASTER = Nothing
End Sub
With 99,999 unique entries in A2:A100000 and 89747 random entries in C2:C89747, this found 70,087 unique new entries not found in A2:A100000 in 9.87 seconds.
I would do it like this:
Sub test()
Dim newRow As Long, oldRow As Long
Dim x As Long, Dim y As Long
Dim checker As Boolean
With ActiveSheet
newRow = .Cells(.Rows.Count,7).End(xlUp).Row
oldRow = .Cells(.Rows.Count,1).End(xlUp).Row
checker = True
for y = 1 To oldRow
for x = 1 To newRow
If .Cells(y,1).Value = .Cells(x,7).Value Then
checker = False
Exit For
End If
Next
If checker Then
Range("E10000").End(xlUp).Offset(1,0).Value = .Cells(y,1).Value
End If
checker = True
Next
End With
End Sub
VLookup is a worksheet function, not a regular VBA function, thus it's for searching in Ranges, not Collections.
Syntax: VLOOKUP (lookup_value, table_array, col_index_num, [range_lookup])
[...]
table_array (required): the range of cells in which the VLOOKUP will search for the lookup_value and the return value.
In order to search in other VBA data structures like arrays, collections etc you'll have to figure out some other way and maybe implement it manually.
While #Jeeped suggestion of a Scripting.Dictionary object might be the best one, you could also try using the Filter() function applied to your array.
Alright, maybe I've just been looking at this for too long but I keep getting an expected expression error, which I believe is just a syntax issue but I'm not entirely sure. I'm looping through one sheet and adding unique values of one column as keys to the dictionary while adding the numbers that correspond to the keys together. For example, if I have:
A 2
B 3
B 4
A 5
C 6
I want the dictionary to look like:
A 7
B 7
C 6
Here's my code, any help is appreciated.
Sub Name()
Dim rng As Range
Dim x As Integer
Dim ranga As String
Dim dico As Dictionary
Set dico = New Dictionary
Dim var As Variant
Dim lastrow As Integer
With Worksheets("Sheet1")
lastrow = Range("A" & .Rows.Count).End(xlUp).Row
ranga = "C6" & ":" & "C" & CStr(lastrow)
Set rng = Range(ranga)
For Each var In rng.Cells
If dico.Exists(var.Value) Then
dico(var.Value) = dico(var.Value) + var.Offset(0, 4).Value
Else
dico.add var.Value, var.Offset(0, 4).Value
End If
Next var
End With
With Worksheets("Sheet2")
Set rng = Range("A2")
Dim i As Integer
i = 0
For Each var In dico.Keys
rng.Offset(i).Value = var
rng.Offset(i, 1).Value = dico(var)
Next var
End With
End Sub
I am new to stackoverflow, so I am a but unsure of the appropriate etiquette, but here is a working solution.
Public Sub dict_counter()
Dim counter As New Dictionary
Dim key As Range: Set key = ThisWorkbook.Sheets("sheet1").Range("A1")
While Not IsEmpty(key)
If counter.Exists(key.Value) Then
counter(key.Value) = counter(key.Value) + key.Offset(ColumnOffset:=1)
Else
counter(key.Value) = key.Offset(ColumnOffset:=1)
End If
Set key = key.Offset(RowOffset:=1)
Wend
'Obviously you can output the dict contents to whatever location
'is convenient
Dim k As Variant
For Each k In counter
Debug.Print k; counter(k)
Next k
End Sub
Instead of
dico(var.Value) = dico(var.Value) + var.Offset(0, 4).Value
It should be
dico.Item(var.Value) = dico(var.Value) + var.Offset(0, 4).Value
See MSDN
Also, if you use With, you have to actually put leading .'s where you want to use methods or properties of it like this:
With Worksheets("Sheet1")
lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
End With
See MSDN