I'm new to VBA and I got a issue when trying to get item from collection.
I have a self defined class, A, and I have a collection B=[A1,A2...] by using
B.add A
Then I have a dictionary like C={1:B1, 2:B2...} by using
C.add i, Bi
now I want to get the C(i)(j), I build code like following, but it keeps giving me error: object doesn't support this property or method.
dim levels as variant
levels = C.items
dim level as variant
dim newA as A
for i = 0 to levels.count -1
level = levels(i)
for j = 0 to level.count -1
newA = level(j)
next
next
The error happens when I try to assign the collection and class to variant, i.e. level = levels(i) and, newA = level(j)
I know I could use for each to build loop but I need to use the index, and the object it self(might need to modify the object inside the collection later), so wondering what's the best way to do this. Thanks!
Here's an example which works for me.
Class A just has a single field Public id As String
Sub Tester()
Dim C As Object, items, i As Long, objA As A
Set C = CreateObject("scripting.dictionary")
'populate dictionary with a couple of collections of Class A instances
C.Add 1, New Collection
C(1).Add GetAInstance("Id001")
C(1).Add GetAInstance("Id002")
C.Add 2, New Collection
C(2).Add GetAInstance("Id003")
C(2).Add GetAInstance("Id004")
C(2).Add GetAInstance("Id005")
'looping...
items = C.items
For i = LBound(items) To UBound(items)
For Each objA In items(i)
Debug.Print objA.id
Next objA
Next i
'direct access
Debug.Print C(1)(1).id '> "Id001"
Debug.Print C(2)(3).id '> "Id005"
C(2)(3).id = "New id"
Debug.Print C(2)(3).id '> "New id"
Set objA = C(2)(3) 'Set is required for object-type variables
Debug.Print objA.id '> "New id"
End Sub
'function to return an object of class A with supplied id
Function GetAInstance(idValue)
Dim rv As New A
rv.id = idValue
Set GetAInstance = rv
End Function
Related
I try to fill an array with objects that are created within a loop as follows. The problem is that all cells seem to have the same object in the end. The explanation might be that obj is not a local variable with respect to the loop.
Sub foo()
Dim Arr(1 To 3) As Class1
Dim i As Integer
For i = 1 To 3
Dim obj As New Class1
obj.name = i
Set Arr(i) = obj
Next
For i = 1 To 3
Debug.Print Arr(i).name
Next
End Sub
Surprisingly, the output is
3
3
3
I have also tried to remove the Set and instead have Arr(i) = obj. That results in Object variable or with block variable not set.
Your issue is the declaration of your object.
Dim foo as New bar
That is called a self-assigned declaration what makes setting a new object optional. If you call an objects member and it is not allready set it get's created (implicitSet foo = New bar). But as you allready created an instance (on first call toobj.name). that one is reused and the same reference is stored three times for the same objects-instance. That's why all elements in array return the same value as they are the same objects-instance, not three different ones.
So don't useNewin declarations, then you always need aSet fooand can check the object instance onNothing.
A second issue with your code is that assigninig an object to an array is that deleting elements from an array is error prone and not deleted references lead to not disposed, but unused objects.
The prefered storage for object(-references) is aCollection.
Sub foo()
Dim ObjCollection as Collection
Set ObjCollection = New Collection
Dim i As Integer
For i = 1 To 3
Dim obj As bar
Set obj = New bar
obj.name = i
ObjCollection.Add obj
Next
For i = 1 To 3
Debug.Print ObjCollection(i).name
Next
End Sub
This is the way:-
Sub foo()
Dim Arr(1 To 3) As Variant
Dim i As Integer
For i = 1 To 3
Set Arr(i) = Worksheets(i)
Next
For i = 1 To 3
Debug.Print Arr(i).Name
Next
End Sub
You have 2 ways to do this:
Notes: obj has not been recreated, so when you call for the next time obj in Arr (1) is still affected by the subsequent call.
First:
Sub foo()
Dim Arr(2) As Variant
Dim i As Integer
Dim obj As New Class1
For i = 0 To 2
Set obj = New Class1 '<<<-----
obj.name = i
Set Arr(i) = obj
Next
For i = 0 To 2
Debug.Print Arr(i).name
Next
End Sub
Second:
Sub foo()
Dim Arr(2) As Variant
Dim i As Integer
For i = 0 To 2
Dim obj As New Class1
obj.name = i
Set Arr(i) = obj
Set obj = Nothing <<<-----
Next
For i = 0 To 2
Debug.Print Arr(i).name
Next
End Sub
Try this, it'll save you a lot of headaches. Cheers!
Option Explicit
Sub foo()
Dim Arr(1 To 3) As New Class1 ' < good to know this version
Dim i As Long
For i = 1 To 3
With Arr(i) ' < saves you some typing
.Name = i
Debug.Print .Name
End With
Next
End Sub
It works, but I don't know how:
I want to create a dynamic number of classes, so I use a dictionary for that.
But I can't add a key to each class of the dictionary.
It works when I add each entry of the 1st dictionary to a second dictionary as a couple item/key.
sub test()
Dim dict As New Dictionary
Dim dict2 As New Dictionary
For i = 1 To 2
Set dict(i) = New Cfgadress
dict(i).Col1 = i
dict2.Add "d" & i, dict(i)
Next i
Debug.Print dict2("d1").Col1
Debug.Print dict2("d2").Col1
End Sub
That was a guess and I'm not sure I understand how it works : is the entry of the first dictionary a class object, while the entry of the second dictionary is a dictionary object (couple item/key) ?
No need for the second dictionary. What's the error you're getting with using just one?
Here is my working code:
Add Module: Module1
Sub test()
Dim col1 As Dictionary
Dim classInstance As Class1
Dim counter As Long
' Init the collection
Set col1 = New Dictionary
For counter = 1 To 2
' Set new instance of class
Set classInstance = New Class1
' Set properties in new class instance
classInstance.testfield = "Test value" & counter
' Add it to the collection
col1.Add "test" & counter, classInstance
Next counter
Debug.Print col1.Item("test1").testfield
Debug.Print col1.Item("test2").testfield
End Sub
Class: Class1
Public testfield As String
I think I get it, correct me if I'm wrong.
When I create a dictionary entry with
Set dict(i) = New Cfgadress
It creates a new dictionary entry: blank object of class Cfgadress associated to the key i
Dict(i) refers to the item contained in entry i of the dictionary dict, i.e. to the class object contained.
To change the key, I need to assign a new couple item/key, but the item exists only as entry i of the dictionnary. So I need either :
to use the entry of the dictionary as an item associated with a key in a new dictionary/collection/array (what I did in my code)
or to assign dict(i) to an object, add it to the with a correct key and remove the former one.
Set object as New class
Set object=dict(i)
dict.Add "key", object
dict.remove "1"
Did I get it ?
Your solution is way simpler and that's what I tried first, but I went to dynamic dictionary because on each iteration, updating the class instance was also updating the previous entries of the collection
Set Wb = ThisWorkbook '==================
Set WsCfg = Wb.Sheets("Cfg") '==================
Dim dict_cfg As New Dictionary
Dim coll As New Collection
Set tcfg_adress = New Cfgadress
For i = 3 To 4 '22
If WsCfg.Cells(i, 10) = 1 And WsCfg.Cells(i, 11) = 1 Then
tcfg_adress.Row1 = WsCfg.Cells(i, 4).Value
tcfg_adress.Col1 = WsCfg.Cells(i, 5).Value
tcfg_adress.Lrow = WsCfg.Cells(i, 6).Value
tcfg_adress.Lcol = WsCfg.Cells(i, 7).Value
tcfg_adress.Nbrow = WsCfg.Cells(i, 8).Value
tcfg_adress.Nbcol = WsCfg.Cells(i, 9).Value
coll.Add tcfg_adress, WsCfg.Cells(i, 1)
End If
Next i
Turns out that setting a new class instance in each loop, as I saw you did in your code, solved my problem. I thought there was nothing to do and was investigating in get arounds. Thanks a lot !
I'm trying to implement my own collection in VBA in which to store a list of objects. I'm new to VBA and I need to find a way in which to implement a solution.
What I have: a list of objects with different properties on which the most important is the duration of a specific action.
What I need: I want a sorted list of objects by using a comparator based on a time property (duration of a specific action).
What kind of Collection do you recommend? I need to create my own helper method in order to sort the elements of the collection? VBA has a comparator interface that I can implement on my own collection object?
I have solved quite similar problem using Types.
Option Compare Database
Option Explicit
Type tPersonalData
FamilyName As String
Name As String
BirthDate As Date
End Type
Type tHuman
PersonalData As tPersonalData
Height As Integer
CashAmount As Integer
End Type
Public Sub subUsage()
Dim Humans(10) As tHuman
Dim HumanCurrent As tHuman
With HumanCurrent
.CashAmount = 100
.Height = 190
.PersonalData.FamilyName = "Smith"
.PersonalData.Name = "John"
.PersonalData.BirthDate = CDate("01.01.1980")
End With
Humans(1) = HumanCurrent
End Sub
So after that you can implement your own sorting functions for an array, using given field.
I have created a sorting method based on Van Ng's, in order to sort my objects like that:
Public Sub sortedCollectionByDuration()
Dim vItm As ClsCron
Dim i As Long, j As Long
Dim vTemp As Variant
Set vTemp = New ClsCron
Set vItm = New ClsCron
For i = 1 To myCol.Count - 1
For j = i + 1 To myCol.Count
If myCol(i).Duration > myCol(j).Duration Then
Set vTemp = myCol(j)
myCol.Remove j
myCol.add vTemp, , i
End If
Next j
Next i
-- testing or logging
For Each vItm In myCol
Debug.Print vItm.ModuleName & " " & vItm.FunctionName & VBA.Format(vItm.Duration, "HH:MM:SS")
Next vItm
End Sub
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
I have an Excel VBA project that makes heavy use of Windows Scripting Dictionary objects. I recently had a user attempt to use it on a Mac and received the following error:
Compile Error: Can't find project or library
Which is the result of using the Tools > References > Microsoft Scripting Runtime library.
My question is, is there a way to make this work on a Mac?
The following are the 3 cases I can think of as being possible solutions:
Use a Mac plugin that enables use of Dictionaries on Macs (my favorite option if one exists)
Do some kind of variable switch like the following:
isMac = CheckIfMac
If isMac Then
' Change dictionary variable to some other data type that is Mac friendly and provides the same functionality
End If
Write 2 completely separate routines to do the same thing (please let this not be what needs to happen):
isMac = CheckIfMac
If isMac Then
DoTheMacRoutine
Else
DoTheWindowsRoutine
End If
Pulling the Answer from the comments to prevent link rot.
Patrick O'Beirne # sysmod wrote a class set that addresses this issue.
Be sure to stop by Patirk's Blog to say thanks! Also there is a chance he has a newer version.
save this as a plain text file named KeyValuePair.cls and import into Excel
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "KeyValuePair"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
'Unrestricted class just to hold pairs of values together and permit Dictionary object updating
Public Key As String
Public value As Variant
save this as a plain text file named Dictionary.cls and import into excel
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "Dictionary"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
'Collection methods: Add, Count, Item, Remove
'Dictionary : .Add(Key as string, Item as variant), .CompareMode, .Count, .Exists(Key); _
.Item(Key) - writeable, .Items, .Keys, .Remove(Key), .RemoveAll
'plus KeyValuePairs collection, KeyValuePair(Index as long), Tag as variant
' 25-11-2011 KeyValuePair helper object
Public KeyValuePairs As Collection ' open access but allows iteration
Public Tag As Variant ' read/write unrestricted
Private Sub Class_Initialize()
Set KeyValuePairs = New Collection
End Sub
Private Sub Class_Terminate()
Set KeyValuePairs = Nothing
End Sub
' in Scripting.Dictionary this is writeable, here we have only vbtextCompare because we are using a Collection
Public Property Get CompareMode() As VbCompareMethod
CompareMode = vbTextCompare '=1; vbBinaryCompare=0
End Property
Public Property Let Item(Key As String, Item As Variant) ' dic.Item(Key) = value ' update a scalar value for an existing key
Let KeyValuePairs.Item(Key).value = Item
End Property
Public Property Set Item(Key As String, Item As Variant) ' Set dic.Item(Key) = value ' update an object value for an existing key
Set KeyValuePairs.Item(Key).value = Item
End Property
Public Property Get Item(Key As String) As Variant
AssignVariable Item, KeyValuePairs.Item(Key).value
End Property
' Collection parameter order is Add(Item,Key); Dictionary is Add(Key,Item) so always used named arguments
Public Sub Add(Key As String, Item As Variant)
Dim oKVP As KeyValuePair
Set oKVP = New KeyValuePair
oKVP.Key = Key
If IsObject(Item) Then
Set oKVP.value = Item
Else
Let oKVP.value = Item
End If
KeyValuePairs.Add Item:=oKVP, Key:=Key
End Sub
Public Property Get Exists(Key As String) As Boolean
On Error Resume Next
Exists = TypeName(KeyValuePairs.Item(Key)) > "" ' we can have blank key, empty item
End Property
Public Sub Remove(Key As String)
'show error if not there rather than On Error Resume Next
KeyValuePairs.Remove Key
End Sub
Public Sub RemoveAll()
Set KeyValuePairs = Nothing
Set KeyValuePairs = New Collection
End Sub
Public Property Get Count() As Long
Count = KeyValuePairs.Count
End Property
Public Property Get Items() As Variant ' for compatibility with Scripting.Dictionary
Dim vlist As Variant, i As Long
If Me.Count > 0 Then
ReDim vlist(0 To Me.Count - 1) ' to get a 0-based array same as scripting.dictionary
For i = LBound(vlist) To UBound(vlist)
AssignVariable vlist(i), KeyValuePairs.Item(1 + i).value ' could be scalar or array or object
Next i
Items = vlist
End If
End Property
Public Property Get Keys() As String()
Dim vlist() As String, i As Long
If Me.Count > 0 Then
ReDim vlist(0 To Me.Count - 1)
For i = LBound(vlist) To UBound(vlist)
vlist(i) = KeyValuePairs.Item(1 + i).Key '
Next i
Keys = vlist
End If
End Property
Public Property Get KeyValuePair(Index As Long) As Variant ' returns KeyValuePair object
Set KeyValuePair = KeyValuePairs.Item(1 + Index) ' collections are 1-based
End Property
Private Sub AssignVariable(variable As Variant, value As Variant)
If IsObject(value) Then
Set variable = value
Else
Let variable = value
End If
End Sub
Public Sub DebugPrint()
Dim lItem As Long, lIndex As Long, vItem As Variant, oKVP As KeyValuePair
lItem = 0
For Each oKVP In KeyValuePairs
lItem = lItem + 1
Debug.Print lItem; oKVP.Key; " "; TypeName(oKVP.value);
If InStr(1, TypeName(oKVP.value), "()") > 0 Then
vItem = oKVP.value
Debug.Print "("; CStr(LBound(vItem)); " to "; CStr(UBound(vItem)); ")";
For lIndex = LBound(vItem) To UBound(vItem)
Debug.Print " (" & CStr(lIndex) & ")"; TypeName(vItem(lIndex)); "="; vItem(lIndex);
Next
Debug.Print
Else
Debug.Print "="; oKVP.value
End If
Next
End Sub
'NB VBA Collection object index is 1-based, scripting.dictionary items array is 0-based
'cf Scripting.Dictionary Methods s.Add(Key, Item), s.CompareMode, s.Count, s.Exists(Key); _
s.Item(Key) - updateable, s.Items, s.Key(Key), s.Keys, s.Remove(Key), s.RemoveAll
'Scripting.Dictionary has no index number; you can index the 0-based variant array of Items returned
' unlike Collections which can be indexed starting at 1
'Efficient iteration is For Each varPair in thisdic.KeyValuePairs
'Another difference I introduce is that in a scripting.dictionary, the doc says
' If key is not found when changing an item, a new key is created with the specified newitem.
' If key is not found when attempting to return an existing item, a new key is created and its corresponding item is left empty.
'but I want to raise an error when addressing a key that does not exist
'similarly, the scripting.dictionary will create separate integer and string keys for eg 2
Patirk's implementation doesn't work for MS Office 2016 on Mac. I made use of the implementation by Tim Hall.
Here is the link: https://github.com/VBA-tools/VBA-Dictionary
Also import of cls files into Excel doesn't work in MS Office 2016 on Mac as of September 2017. So I had to create a class module and to copy and paste the contents of Dictionary.cls manually in that module while removing meta info from Dictionary.cls such as VERSION 1.0 CLASS, BEGIN, END, Attribute.
I have at last updated the files for Excel 2016 for Mac.
http://www.sysmod.com/Dictionary.zip
(capital D in Dictionary)
Unzip this and import the class files (tested in Excel 2016 for Mac 16.13 Build 424, 27-Apr-2018)
My bug report to MS is at answers.microsoft.com
Excel 16.13 for Mac User Defined Class passed as parameter all properties are Null
Let me know if I've missed anything else!
Good luck,
Patrick O'Beirne