Already looked in the forum but was not able to find anything similar.
I would like to create a string array where the index “value” is a string.
For instance:
MyArray(“abc”)=1
MyArray(“def”)=2
MyArray(“ghi”)=3
Is there a way to do this in VBA or can I achieve the same in a different way?
A Dictionary Introduction
A Simple Example
Sub DictIntroduction()
Dim InitText As Variant, InitNumbers As Variant
InitText = Array("abc", "def", "ghi")
InitNumbers = Array(1, 2, 3)
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
Dim i As Long
For i = 0 To UBound(InitText)
dict.Add InitText(i), InitNumbers(i)
Next
Dim Key As Variant
For Each Key In dict.Keys
Debug.Print Key, dict(Key)
Next
Debug.Print dict("abc")
Debug.Print dict("def")
Debug.Print dict("ghi")
End Sub
To find out more about the dictionary visit the following links:
Excel VBA Dictionary - A Complete Guide (Article)
Excel VBA Dictionary (YouTube Playlist)
Sub main()
Set myArray = CreateObject("Scripting.Dictionary")
myArray("abc") = 1
myArray("def") = 2
myArray("ghi") = 3
Debug.Print myArray("abc")
For Each tempKey In myArray
Debug.Print tempKey, myArray(tempKey)
Next
End Sub
Related
I am trying to add a column as the key and the column to the right of it as the value.
Can I do this without a loop?
I tried:
analystDict.Add Key:=refWS.Range("A2:A21"), Item:=refWS.Range("B2:B21")
When I try to Debug.Print I get a Type mismatch error:
For Each x In analystDict.Keys
Debug.Print x, analystDict(x)
Next x
You can't do this in VBA without writing a helper function.
Option Explicit
Public Sub AddTest()
Dim analystDict As Scripting.Dictionary
Set analystDict = New Scripting.Dictionary
Dim refWS As Worksheet
Set refWS = ActiveSheet
AddToDictionary _
analystDict, _
Application.WorksheetFunction.Transpose(refWS.Range("A2:A21").Value), _
Application.WorksheetFunction.Transpose(refWS.Range("B2:B21").Value)
End Sub
Public Sub AddToDictionary(ByRef ipDict As Scripting.Dictionary, ByVal ipKeys As Variant, ByVal ipValues As Variant)
If UBound(ipKeys) <> UBound(ipValues) Then
MsgBox "Arrays are not the same size"
Exit Function
End If
Dim myIndex As Long
For myIndex = LBound(ipKeys) To UBound(ipKeys)
ipDict.Add ipKeys(myIndex), ipValues(myIndex)
Next
End Function
You're taking a shortcut that's not allowed; Dictionary.Add is implemented such that it expects one key/value pair, and adds one item to the dictionary. If you need to add multiple items, you need multiple calls to Dictionary.Add - there's no way around it.
A shortcut that would be allowed though, would be to just grab the values in any 2-column Range and turn that into a dictionary, rather than taking any random two arrays that may or may not be the same size.
Make a function that takes a 2D array and turns it into a dictionary by treating the first column as unique keys, and the second column as values.
Public Function ToDictionary(ByVal keyValuePairs As Variant) As Scripting.Dictionary
If Not IsArray(keyValuePairs) Then Err.Raise 5
If GetDimensions(keyValuePairs) <> 2 Then Err.Raise 5 'see https://stackoverflow.com/q/6901991/1188513
Dim result As Scripting.Dictionary
Set result = New Scripting.Dictionary
Const KEYCOL = 1, VALUECOL = 2
Dim i As Long
For i = LBound(keyValuePairs, KEYCOL) To UBound(keyValuePairs, KEYCOL)
If result.Exists(keyValuePairs(i, KEYCOL)) Then Err.Raise 457
result.Add Key:=keyValuePairs(i, KEYCOL), Item:=keyValuePairs(i, VALUECOL)
Next
Set ToDictionary = result
End Function
Now you can turn any 2-column Range into a Dictionary like this:
Dim things As Scripting.Dictionary
Set things = ToDictionary(Sheet1.Range("A2:B21").Value)
Note that Range.Value yields a 1-based, 2D Variant array whenever it refers to multiple cells.
Nice concept, Mathieu and you can even simplify this a bit. If you don't mind that a later key-value pair overwrites the most recent one then you can skip raising an error and do this:
Public Function ToDictionary(ByVal keyValuePairs As Variant) As Scripting.Dictionary
If Not IsArray(keyValuePairs) Then err.Raise 5
If GetDimensions(keyValuePairs) <> 2 Then err.Raise 5 'see https://stackoverflow.com/q/6901991/1188513
Dim result As Scripting.Dictionary
Set result = New Scripting.Dictionary
Const KEYCOL = 1, VALUECOL = 2
Dim i As Long
For i = LBound(keyValuePairs, KEYCOL) To UBound(keyValuePairs, KEYCOL)
' No need to check if you don't mind have subsequent instance of key-value overwrite the
' the current one.
' If result.Exists(keyValuePairs(i, KEYCOL)) Then err.Raise 457
result(keyValuePairs(i, KEYCOL)) = keyValuePairs(i, VALUECOL)
Next
Set ToDictionary = result
End Function
I am trying to now learn how Dictionaries work within VBA, so I created a simple Class Module, A Function, and then two subs, but for reasons beyond me the For loop is completely skipped within the function. Below is the Code for all of the items mentioned above. I do have the Microsoft Scripting Runtime checked in Tools > References. Im not really familiar with how Late and Early Binding are utilized, so I'm wondering if that's one of the issues.
Currently the Set rg = LoanData.Range("AH2") is in a table, I have tried the data in that range as both a table and also as just a range, but the For Loop in the function is skipped if the data is in a Table or not.
Class Module called clsCounty
Public CountyID As Long
Public County As String
Function called ReadCounty
Private Function ReadCounty() As Dictionary
Dim dict As New Dictionary
Dim rg As Range
Set rg = LoanData.Range("AH2")
Dim oCounty As clsCounty, i As Long
For i = 2 To rg.Rows.Count
Set oCounty = New clsCounty
oCounty.CountyID = rg.Cells(i, 1).Value
oCounty.County = rg.Cells(i, 2).Value
dict.Add oCounty.CountyID, oCounty
Next i
Set ReadCounty = dict
End Function
The two subs to write to the immediate window
Private Sub WriteToImmediate(dict As Dictionary)
Dim key As Variant, oCounty As clsCounty
For Each key In dict.Keys
Set oCounty = dict(key)
With oCounty
Debug.Print .CountyID, .County
End With
Next key
End Sub
Sub Main()
Dim dict As Dictionary
Set dict = ReadCounty
WriteToImmediate dict
End Sub
You've declared your range as Set rg = LoanData.Range("AH2") and then use For i = 2 To rg.Rows.Count in your loop. the rg.Rows.Count will be 1 as there is only 1 cell in your range. This is before the starting value for your For loop (2) so it won't do anything.
i.e. For i = 2 to 1
Declare your rg variable with the full range. I'm going to guess something like
With LoanData
Set rg = .Range(.Cells(1,"AH"), .Cells(.Cells(.Rows.Count, "AH").End(xlUp).Row, "AH"))
End With
The problem is indeed in the usage of Set rg = LoanData.Range("AH2"), as mentioned in the other answer.
However, to be a bit more elegant, you may consider using LastRow, function, which takes as arguments columnToCheck and wsName:
Public Function LastRow(wsName As String, Optional columnToCheck As Long = 1) As Long
Dim ws As Worksheet
Set ws = Worksheets(wsName)
LastRow = ws.Cells(ws.Rows.Count, columnToCheck).End(xlUp).Row
End Function
In the code, it would look like this:
Private Function ReadCounty() As Dictionary
Dim dict As New Dictionary
Dim oCounty As clsCounty, i As Long
'For i = 2 To LastRow("LoanData", 34)
For i = 2 To LastRow(LoanData.Name, Range("AH1").Column)
Set oCounty = New clsCounty
oCounty.CountyID = LoanData.Cells(i, "AH").Value
oCounty.County = LoanData.Cells(i, "AI").Value
dict.Add oCounty.CountyID, oCounty
Next i
Set ReadCounty = dict
End Function
I have a combobox in an Excel UserForm that I would like to sort alphabetically. I don't have any idea how to add this function, and I would appreciate any help. Here is my VBA:
Private Sub Userform_Initialize()
' Sets range for ComboBox list
Dim rng As Range, r As Range
Set rng = Sheet1.Range("H2:H65536")
For Each r In rng
AddUnique r.value
Next r
End Sub
Sub AddUnique(value As Variant)
Dim i As Integer
Dim inList As Boolean
inList = False
With Me.ComboBox1
For i = 0 To Me.ComboBox1.ListCount - 1
If Me.ComboBox1.List(i) = value Then
inList = True
Exit For
End If
Next i
If Not inList Then
.AddItem value
End If
End With
End Sub
My suggestion is to use a Dictionary to create a collection of only the unique value in your range, then sort it prior to adding the items to your combobox.
If you haven't done so already, add a reference library to your project by going to the Tools menu, then select References. Scroll down the list and find the "Microsoft Scripting Runtime" and check it.
Then it's a simple matter of looping through all the entries -- only adding an item if it doesn't exist already. I lifted a sorting routine from ExcelMastery. Then add the items to your combobox.
Option Explicit
Private Sub Userform_Initialize()
' Sets range for ComboBox list
Dim rng As Range, r As Range
Set rng = Sheet1.Range("H2:H65536")
'--- create a dictionary of the items that will be in
' the combobox
Dim uniqueEntries As Object
Set uniqueEntries = New Scripting.Dictionary
For Each r In rng
'--- all dictionary keys must be a string
Dim keyString As String
If IsNumeric(r) Then
keyString = CStr(r)
Else
keyString = r
End If
If Not uniqueEntries.exists(keyString) Then
uniqueEntries.Add CStr(keyString), r
End If
Next r
Set uniqueEntries = SortDictionaryByKey(uniqueEntries)
CreateComboboxList uniqueEntries
End Sub
Private Sub CreateComboboxList(ByRef dictList As Scripting.Dictionary)
Dim key As Variant
For Each key In dictList.keys
Debug.Print "Adding " & key
'Me.combobox1.AddItem key
Next key
End Sub
'------------------------------------------------------------------
'--- you should put this in a module outside of your userform code
Public Function SortDictionaryByKey(dict As Object, _
Optional sortorder As XlSortOrder = xlAscending) As Object
'--- from ExcelMastery
' https://excelmacromastery.com/vba-dictionary/#Sorting_by_keys
Dim arrList As Object
Set arrList = CreateObject("System.Collections.ArrayList")
' Put keys in an ArrayList
Dim key As Variant, coll As New Collection
For Each key In dict
arrList.Add key
Next key
' Sort the keys
arrList.Sort
' For descending order, reverse
If sortorder = xlDescending Then
arrList.Reverse
End If
' Create new dictionary
Dim dictNew As Object
Set dictNew = CreateObject("Scripting.Dictionary")
' Read through the sorted keys and add to new dictionary
For Each key In arrList
dictNew.Add key, dict(key)
Next key
' Clean up
Set arrList = Nothing
Set dict = Nothing
' Return the new dictionary
Set SortDictionaryByKey = dictNew
End Function
I have typed the following code in Excel VBA:
The function should create a dictionary acording to unique values in a certain column part.
Function CreateDictForFactors(xcord As Integer, ycord As Integer, length As Integer) As Dictionary
Dim Dict As Dictionary
Set Dict = New Dictionary
Dim i As Integer
For i = 0 To length - 1
If Not Dict.Exists(Cells(xcord + i, ycord)) Then
Dict.Add Cells(xcord + i, ycord), 0
End If
Next i
Set CreateDictForFactors = Dict
End Function
Sub test2()
Dim dict1 As Dictionary
Set dict1 = CreateDictForFactors(7, 6, 12)
End Sub
I found this code as an excample for dictionaries and functions:
Sub mySub()
dim myDict as Dictionary
set myDict = myFunc()
End Sub
Function myFunc() as Dictionary
dim myDict2 as Dictionary
set myDict2 = new Dictionary
'some code that does things and adds to myDict2'
set myFunc=myDict2
End Function
However when I try to run the makro test2 it gives the error message:
User-defined type not defined
Can anyone tell where I made a mistake?
Thank you in advance
G'day,
Did you add "Microsoft Scripting Runtime" as a reference to your project?
Once you've done that, declare dict as a Scripting.Dictionary like this:
Dim dict As Scripting.Dictionary
You can create the object as follows:
Set dict = New Scripting.Dictionary
This is a good website describing the use of a dictionary:
https://excelmacromastery.com/vba-dictionary/
Hope this helps.
You can also late bind the code like this:
Function CreateDictForFactors(xcord As Integer, ycord As Integer, length As Integer) As Dictionary
Dim Dict As Object
Set Dict = CreateObject("Scripting.Dictionary")
Dim i As Integer
For i = 0 To length - 1
If Not Dict.Exists(Cells(xcord + i, ycord)) Then
Dict.Add Cells(xcord + i, ycord), 0
End If
Next i
Set CreateDictForFactors = Dict
End Function
Sub test2()
Dim dict1 As Object
Set dict1 = CreateDictForFactors(7, 6, 12)
End Sub
Note that neither method will work on a Mac.
I'm trying to create a dictionary which has a collection for every key. The reason for this is that I want to retrieve several values from the same key later on. In this example I want to have the total value (val) of a unique key as well as the number of occurrences (n):
sub update()
Dim dict As Dictionary
Dim coll As Collection
Set dict = New Dictionary
Set coll = New Collection
coll.Add 100, "val"
coll.Add 3, "n"
dict.Add "coll", coll
Debug.Print dict.item("coll")("val")
Debug.Print dict.item("coll")("n")
This works fine so far, the problem occurs when I try to update the value in the collection (object doesn't support this):
dict.item("coll")("val") = dict.item("coll")("val") + 100
What I tried:
If I use an array instead of the collection, there is no error but the value doesn't change.
It only works if I read out the collection to variables, change the value, create a new collection, remove the old from the dictionary and add the new collection.
Is there any way to do it like my approach above in a single line?
I would also be happy for an alternative solution to the task.
Once you added an item to the collection, you cannot change it that easily. Such expression:
coll("n") = 5
will cause Run-time error '424': Object required.
You can check it by yourself on the simple example below:
Sub testCol()
Dim col As New VBA.Collection
Call col.Add(1, "a")
col("a") = 2 '<-- this line will cause Run-time error '424'
End Sub
The only way to change the value assigned to the specified key in the given collection is by removing this value and adding another value with the same key.
Below is the simple example how to change the value assigned to a collection with key [a] from 1 to 2:
Sub testCol()
Dim col As New VBA.Collection
With col
Call .Add(1, "a")
Call .Remove("a")
Call .Add(2, "a")
End With
End Sub
Below is your code modified in order to allow you to change the value assigned to the given key in the collection:
Sub update()
Dim dict As Dictionary
Dim coll As Collection
Set dict = New Dictionary
Set coll = New Collection
coll.Add 100, "val"
coll.Add 3, "n"
dict.Add "coll", coll
Debug.Print dict.Item("coll")("val")
Debug.Print dict.Item("coll")("n")
'This works fine so far, the problem occurs when I try to update the value in the collection (object doesn't support this):
Dim newValue As Variant
With dict.Item("coll")
newValue = .Item("val") + 100
On Error Resume Next '<---- [On Error Resume Next] to avoid error if there is no such key in this collection yet.
Call .Remove("val")
On Error GoTo 0
Call .Add(newValue, "val")
End With
End Sub
It is not elegant perhaps, but maybe you can write a sub to update a collection by a key:
Sub UpdateCol(ByRef C As Collection, k As Variant, v As Variant)
On Error Resume Next
C.Remove k
On Error GoTo 0
C.Add v, k
End Sub
Used like this:
Sub Update()
Dim dict As Dictionary
Dim coll As Collection
Set dict = New Dictionary
Set coll = New Collection
coll.Add 100, "val"
coll.Add 3, "n"
dict.Add "coll", coll
Debug.Print dict.Item("coll")("val")
Debug.Print dict.Item("coll")("n")
UpdateCol dict.Item("coll"), "val", dict.Item("coll")("val") + 100
Debug.Print dict.Item("coll")("val")
End Sub
With output as expected:
100
3
200
Here is an approach using a User Defined Object (Class). Hoepfully you can adapt this to your problem.
Rename the Class Module cMyStuff or something else meaningful.
Class Module
Option Explicit
Private pTotalVal As Long
Private pCounter As Long
Public Property Get TotalVal() As Long
TotalVal = pTotalVal
End Property
Public Property Let TotalVal(Value As Long)
pTotalVal = Value
End Property
Public Property Get Counter() As Long
Counter = pCounter
End Property
Public Property Let Counter(Value As Long)
pCounter = Value
End Property
Regular Module
Option Explicit
Sub Update()
Dim cMS As cMyStuff, dMS As Dictionary
Dim I As Long
Set dMS = New Dictionary
For I = 1 To 3
Set cMS = New cMyStuff
With cMS
.Counter = 1
.TotalVal = I * 10
If Not dMS.Exists("coll") Then
dMS.Add "coll", cMS
Else
With dMS("coll")
.TotalVal = .TotalVal + cMS.TotalVal
.Counter = .Counter + 1
End With
End If
End With
Next I
With dMS("coll")
Debug.Print "Total Value", .TotalVal
Debug.Print "Counter", .Counter
End With
End Sub
Results in Immediate Window
Total Value 60
Counter 3