Looping through Collection of Dictionaries - vba

I have created a collection of dictionaries and have NO idea how to loop through them all.
The collection consists of the various types of animals that a farm may have:
Cows
Dogs
Swans
Each of these are dictionaries containing more details on the types of animals within that group:
Cows (Spotted, White, White, Black)
Dogs (Big, Middle, Middle, Small)
Swans (Cream, Dark)
I am trying to have an overview of my dataset - to see which 'unique' types of Cows, Dogs and Swans I have.
To do this, I was thinking of first looping through the collection of animals, and then go into each dictionary to screen through the list and extract the unique values.
Easier said than done :P
Here's what I have so far... and it's getting me nowhere:
Dim Cows, Dogs, Swans as Object
Set Cows = CreateObject("scripting.dictionary")
Set Dogs = CreateObject("scripting.dictionary")
Set Swans = CreateObject("scripting.dictionary")
[...Add all the farm data into the 3 categories above...]
Dim TotalAnimals As New Collection, AnimalType
TotalAnimals.Add Cows
TotalAnimals.Add Dogs
TotalAnimals.Add Swans
For Each AnimalType In TotalAnimals
For Each Animal In AnimalType <<< HERE lies my error
[Code for selecting unique values, works perfectly]
Next Animal
Next Animaltype
Any ideas on how to solve this (fairly simple) question?

Related

Matching and Placing Values from Another Table

I'm trying to develop a check box switch on a form that auto-fills a check mark when the correct value is selected.
Item
Group
Category
Keyboard
Medium
Electronics
Laptop
High
Electronics
Mouse Pad
Low
Electronics
Apple
Low
Food
Wine
High
Food
Milk
Medium
Food
Goal:
I have a listbox that allows multiple selection of items, given a certain criteria "Category". The list automatically updates based on the category selected. Once selected, I want to see if the item selected falls under a certain "Group", either low, medium, or high.
Current Code:
' Create Array for multiple selection box
Dim ct As Integer, v, ArrCT()
ReDim ArrCT(ct = 0 To Me.testbutton.ItemsSelected.Count - 1)
For Each v In Me.testbutton.ItemsSelected
ArrCT(ct) = Me.testbutton.ItemData(v)
ct = 1 + ct
Next v
' Load table for matching
Dim db As Database
Dim rs As Recordset
Set db = CurrentDb
Set rs = db.OpenRecordset("MasterList")
Dim qmct As Integer, x, NewArr()
ReDim NewArr(qmct = 0 to Me.testbutton.ItemsSelected.Count - 1)
For Each x In Me.testbutton.ItemsSelected
NewArr(qmct) = ArrCT(x)
If NewArr(qmct) = rs![Item] Then
NewArr(qmct) = rs![Group]
End If
qmct = 1 + qmct
Next x
My idea was to create a temporary array which stores the selection, and then have a second for-loop go through the array to match the correct "group".
With the second array, despite triple checking the field name, I get:
Run-time error '3265':
Item not found in this collection.
Item information is loaded in the ArrCT array, and adjusts based on the number of selection.
Is there an easier way to call for a value in the table?
*Note: sample table is not my actual data, that has approximately 20 times more items, category and grouping.

VBA dynamically populate nested data structure

I have a few SQL tables, some which are linked, that I would like to query once and store locally in a single variable. I can't predict the length of the data ahead of time so I need a dynamic data structure.
Example data I'm querying:
Table 1
NameA
Red
Green
Blue
Table 2
NameA NameB
Red A
Red B
Red C
Blue D
Blue E
Green F
Table 3
NameA NameC
Red One
Blue Two
Blue Three
Blue Four
Blue Five
Green Six
Green Seven
I need to be able to filter and access NameB and NameC based on NameA values. I would prefer a nested dictionary structure where I could query like below:
Table1("0") 'will equal "Red"
Table2("Red")("0") 'will equal "A"
Table2("Blue")("1") 'will equal "E"
Table3("Green")("1") 'will equal "Seven"
'note: point here is data structure, not order of results
I have tried using VBA's nested dictionaries but have been unable to get around the lack of a "deep copy" function. One algorithm I wrote:
With SqlQueryResult
i = 0
Do Until .EOF
Call Table1.Add(CStr(i), .Fields(0).Value)
i = i + 1
.MoveNext
Loop
End With
For Each key In Table1.Keys
SqlQueryResult = GetResultsFromQuery(SELECT NameB WHERE NameA = Table1(key))
With SqlQueryResult
i = 0
Do Until .EOF
Call TempDict.Add(CStr(i), .Fields(0).Value)
i = i + 1
.MoveNext
Loop
End With
Set Table2(Table1(key)) = TempDict
TempDict.RemoveAll
Next key
Unfortunately assigning a Dict to another Dict only sets a reference and doesn't actually copy over data -- when I delete TempDict, the nested data from Table2 is also removed.
I also can't have a new dictionary per "branch" in the nest structure as I need this data to be available at a module-level scope, and therefore need to define these in the top of the module before program execution.
I've looked at multi-dimentional dynamic arrays - these can't be assigned to a parent structure like a dictionary. I also can't predict the size of each of these tables, e.g. Table1 might be 5/20/100/etc in size, Red may have 2/5/100/etcetc results in Table 2, Blue have 1/20/etcetc results in Table 2. Redim only works on a single dimension in an array.
I've had a brief look at Collections as well, and I am not sure these are viable.
I don't have much experience with classes and I would rather avoid a very involved process - I want it to be easy to add linked and unliked (i.e. data linked to Table 1, like Table 2 and 3, vs stand-alone data not related to any other table) to this program should I need to in the future. (My benchmark for "easy" is a pandas dataframe in python).
A simple wrapper class for scripting dictionaries which implements a clone method. This should work fine with primitive datatypes.
Option Explicit
Private Type State
Dict As scripting.Dictionary
End Type
Private s As State
Private Sub Class_Initialize()
Set s.Dict = New scripting.Dictionary
End Sub
Public Function Clone()
Dim myClone As scripting.Dictionary
Set myClone = New scripting.Dictionary
Dim myKey As Variant
For Each myKey In s.Dict
myClone.Add myKey, s.Dict.Item(myKey)
Next
Set Clone = myClone
End Function
Public Property Get Item(ByVal Key As Variant) As Variant
Item = s.Dict.Item(Key)
End Property
Public Property Set Item(ByVal Key As Variant, ByVal Value As Variant)
s.Dict.Item(Key) = Value
End Property
Public Sub Add(ByVal Key As Variant, ByVal Item As Variant)
s.Dict.Add Key, Item
End Sub
You will now be able to say
Set Table2.Item(Table1.Item(key)) = TempDict.Clone

Two-column list-box with input

I'm trying to create a control (for the first time) that pops up and shows the user two columns: The column on the left has labels and the column on the right has empty text boxes for user input.
For example:
---------------------
Ingredient | Quantity
---------------------
Carrots |
---------------------
Apples |
---------------------
Bananas |
And so on. It's important that they are able to scroll together.
I have no idea where to start :/ Should I be looking at tables? listboxes?
I know I can't use textboxes because the number of "ingredients" changes every time the control is called
There is a great deal we don't know about the use-case or (real) data and source. One way to display and edit a varying number of items is the DataGridView. If it is on a modal dialog, it 'pops up':
' form level collection of things
Private Recipe As List(Of RecipeItem)
...
' prepare the data and display:
Recipe = New List(Of RecipeItem)
Recipe.Add(New RecipeItem With {.Ingredient = "Carrot"})
Recipe.Add(New RecipeItem With {.Ingredient = "Apple"})
Recipe.Add(New RecipeItem With {.Ingredient = "Banana"})
Recipe.Add(New RecipeItem With {.Ingredient = "Hemlock"})
...
Dim UmCol As New DataGridViewComboBoxColumn
UmCol.DataPropertyName = "UnitMeasure"
UmCol.DataSource = [Enum].GetValues(GetType(UnitMeasure))
dgvDD.DataSource = Recipe
dgvDD.Columns.Remove("UnitMeasure")
dgvDD.Columns.Add(UmCol)
The DGV will save user edits back to the underlying datasource - the recipe list, in this case.
' elsewhere
For Each item In Recipe
Console.WriteLine(item.ToString)
Next
Result:
2 Each of Carrot
1 Tsp of Apple
1.5 Cup of Banana
3 Bushel of Hemlock
A UserControl with dynamically built TextBox controls will also work, but you likely still need a collection to store the data. If the data comes from a database, the DGV will still work fine, just use a DataTable as the source rather than the Recipe collection.

Dictionary seemingly pulling same value for all keys (VBA)

I have a dictionary in which each key is a number 0-7. Each item is a collection of two number values. For each value in the dataset I am iterating through, the code checks which key 1-7 it belongs to, pulls the appropriate collection from the dictionary, adds the data to the collection, and inserts the collection back into the dictionary. It also adds every value to the 0 key in the dictionary, so that at the end the 0 key will contain a grand total i.e. the output should look like this:
Key:Value
0:100
1:20
2:10
3:10
4:20
5:10
6:5
7:25
The problem that I am having is that the output is something like:
Key:Value
0:100
1:100
2:100
3:100
4:100
5:100
6:100
7:100
It seems like each time I pull a collection from the dictionary using a key it, pulls the same collection regardless of key and then adds the data to that collection.
Dictionary:
For region = 0 To 7
regDict.Add region, blankColl
Next region
Adding items:
thisRegion = 'some number 1-7 found elsewhere
' pull the collection from the regDict
Set subtotalColl = regDict.Item(thisRegion)
subtotalSales = subtotalColl("Item") + thisSales
subtotalColl.Remove ("Item")
subtotalColl.Add Item:=subtotalSales, Key:="Item"
' replace the collection for thisRegion with the new one
regDict.Remove thisRegion
regDict.Add thisRegion, subtotalColl
' ----------- "region 0" gets every record no matter
' ----------- what the region of the record is
' pull the collection at 0 from the regDict
Set zeroSubtotalColl = regDict.Item(0)
subtotalSales = zeroSubtotalColl("Item") + thisSales
zeroSubtotalColl.Remove ("Item")
zeroSubtotalColl.Add Item:=subtotalSales, Key:="Item"
' replace the collection for Region 0 with the new one
regDict.Remove 0
regDict.Add 0, zeroSubtotalColl
The problem is that when I check the dictionary after all of this is done, every collection contains the same values! Even if I debug within this, zeroSubtotalColl from regDict(0) contains the the "new" value that I just put back into regDict(thisRegion) as subtotalColl.
Any help much appreciated.
blankColl is always a reference to the same collection, and you add it for each key, so all the "values" point to the same object.
Current:
Set regdict = CreateObject("scripting.dictionary")
Set blankColl = New Collection 'guessing here what you did...
For region = 0 To 7
regdict.Add region, blankColl
Next region
regdict(1).Add "hello"
Debug.Print regdict(7).Count '>>1 oops - should be empty!
Fix:
For region = 0 To 7
regdict.Add region, New Collection
Next region
regdict(1).Add "hello"
Debug.Print regdict(7).Count '>>0 still empty!

VBA Sort Based On String Piece

As am new to VBA, I will be thankful if anyo can help me with this.
I want to sort rows based on the presence or absence of a specific text in the whole string.
Range B Contains:
Audi Car, Suzuki Bike, Honda Car, Volvo Bus, Benz Car, Yamaha Bike
So I want VBA code which sorts based on if its a CAR, BIKE or BUS.
After Executing, Range B should be sorted this way:
Audi Car, Benz Car, Honda Car, Suzuki Bike, Yamaha Bike, Volvo Bus
Please help.
If I where to handle a problem like this I would first make an array with all the different entities.
The next thing you can do is to use the InStr(startsearchingposition, String, searchforvalue). The InStr method returns the startposition of searchvalue in String, else it returns 0 or NUll.
So if it has a record the value of Instr returns is greater than 1.
Dim myArray(1 to 3) As Variant, i, number_of_element As Integer, y as String
Dim ws As Worksheet: Set ws = ActiveSheet
myArray(1) = "Car"
myArraY(2) = "Bus"
myArraY(3) = "Bike"
'Lets assume that all you data is in column A
For i = 1 To ws.Cells(rows.count, 1).end(xlup).row
y = ws.Cells(i,1).value
number_of_element = 1
For Each element in myArray
If InStr(1, y, element) > 1 Then
ws.cells(i, number_of_element +1).value = y
Exit For
Else
number_of_element = number_of_element + 1
End if
Next
Next i
Maybe this doens't completely satisfied you criteria but at least all the different entities are now parted.
The Next thing you could do is sort all the elements in every entity en put them back together.
VBA has some useful methods that can be used to parse a certain string.
Mid() and InStr() are the two I use the most.
use Macro to record the following steps:
1.paste data vertically in column A (paste special - transpose)
2.insert function Split by Space to column B (return value eg: bike, car)
3.sort column A and B in the order you like
4.copy column A and paste special - transpose
5.stop Macro recording, change all cells (eg: .range(row,col))