I am trying to create an excel function which will fill column with data gathered from OGame's reports. I have encountered strage behavior (at least from my point of view).
I have a form where the user can copy their reports to a form's textbox. After clicking the button, the following functions should start:
Option Explicit
Private Sub CommandButton1_Click()
Dim arr() As String
Dim test As Boolean
Dim str As String
str = testFunction()
arr = readData(Raporty.Value)
' Dim element As Variant
' For Each element In arr
' Debug.Print element
' Debug.Print "-------------------------------"
' Next element
test = writeData(arr)
Debug.Print (test)
Debug.Print ("str: " + str)
Unload ufWczytajRaporty
End Sub
Private Function testFunction() As String
Debug.Print ("testFunction")
testFunction = "testFunctionText"
End Function
Private Function writeData(arr1() As String) As Boolean
Debug.Print ("writeData")
For Each element In arr1
writeDataRow (element)
Next element
writeData = True
End Function
Private Function readData(text As String) As String()
Debug.Print ("readData")
Dim list As Object
Dim substr As Integer
Dim temp As String
Dim arr(0 To 10) As String
Dim result() As String
Dim counter As Integer
Set list = CreateObject("System.Collections.ArrayList")
counter = 0
If text = "" Then
MsgBox "Dane nie mogą być puste! Proszę uzupełnić poprawnymi raportami!", vbCritical
Else
If InStr(1, text, "Przybył statek handlowy") = 1 Then
While (InStr(1, text, "Towar został już odebrany."))
substr = InStr(1, text, "Towar został już odebrany.") + 26
arr(counter) = Left(text, substr)
temp = Mid(text, substr, Len(text))
text = temp
counter = counter + 1
Wend
Unload ufWczytajRaporty
Else
MsgBox "Niepoprawne raporty! Proszę wkleć dobre raporty!", vbCritical
End If
End If
ReDim result(0 To counter)
Dim i As Integer
For i = 0 To counter
result(i) = arr(i)
Next i
readData = arr
End Function
This functions provide the following result in Immediate:
testFunction
readData
False
str: testFunctionText
As you can see the above false is a call of writeData fuction, however it never entered the function. writeData function contains Debug.Print ("writeData") but it was never displayed.
Furthermore if I change places the following function:
str = testFunction()
arr = readData(Raporty.Value)
to
arr = readData(Raporty.Value)
str = testFunction()
testFunction is not called aswell.
Can someone explain me what is happening? Why those functions are not called?
I got an issue with "casting" variants to defined objects.
At runtime my variant variable is of type "Variant/Object/Listbox", which i then want to set to a ListBox variable to route it as a parameter to another function (GetSelected) that requires a Listbox object.
But I get the error 13: types incompatible on command "Set lst = v".
Any ideas how to get it working?
Code:
Function GetEditableControlsValues(EditableControls As Collection) As Collection
'Gibt die Werte der editierbaren Felder zurück.
Dim v As Variant
Dim coll As New Collection
Dim lst As ListBox
For Each v In EditableControls
If TypeName(v) = "ListBox" Then
Set lst = v 'Fehler 13: Typen unverträglich. v zur Laufzeit: Variant/Object/Listbox.
coll.Add GetCollectionString(GetSelected(lst))
Else
coll.Add v.Value
End If
Next
End Function
This is what I have so far:
Imagine that you have a module with the following code in it:
Option Explicit
Public Sub TestMe()
Dim colInput As New Collection
Dim colResult As Collection
Dim lngCount As Long
Dim ufMyUf As UserForm
Set ufMyUf = UserForm1
Set colInput = GetListBoxObjects(ufMyUf)
For lngCount = 1 To colInput.Count
Debug.Print colInput(lngCount).Name
Next lngCount
End Sub
Function GetListBoxObjects(uf As UserForm) As Collection
Dim colResult As New Collection
Dim objObj As Object
Dim ctrCont As Control
For Each ctrCont In uf.Controls
If LCase(Left(ctrCont.Name, 7)) = "listbox" Then
Set objObj = ctrCont
colResult.Add objObj
End If
Next ctrCont
Set GetListBoxObjects = colResult
End Function
If you run TestMe, you would get a collection of the ListBox objects. Anyhow, I am not sure how do you pass them to the collection function, thus I have decided to iterate over the UserForm and thus to check all of the objects on it.
Cheers!
I had problems with casting controls myself and didn't find a general solution that I could use easy.
Eventually I found the way to do it: store as "Object" makes it easy to convert to whatever type the control actually is.
I tested (and use) it
The sub below shows that it works (here : 1 TextBox; 1 ListBox; 1 ComboBox; 1 CommandButton on a worksheet)
Sub Test_Casting()
Dim lis As MSForms.ListBox
Dim txt As MSForms.TextBox
Dim btn As MSForms.CommandButton
Dim com As MSForms.ComboBox
Dim numObjects As Integer: numObjects = Me.OLEObjects.Count
Dim obj() As Object
ReDim obj(1 To numObjects) As Object
Dim i As Integer: i = 0
Dim cttl As OLEObject
For Each ctrl In Me.OLEObjects
i = i + 1
Set obj(i) = ctrl.Object
Next ctrl
Dim result As String
For i = 1 To numObjects
If TypeOf obj(i) Is MSForms.ListBox Then
Set lis = obj(i): result = lis.Name
ElseIf TypeOf obj(i) Is MSForms.TextBox Then
Set txt = obj(i): result = txt.Name
ElseIf TypeOf obj(i) Is MSForms.CommandButton Then
Set btn = obj(i): result = btn.Name
ElseIf TypeOf obj(i) Is MSForms.ComboBox Then
Set ComboBox = obj(i): result = com.Name
Else
result = ""
End If
If (Not (result = "")) Then Debug.Print TypeName(obj(i)) & " name= " & result
Next i
For i = 1 To numObjects
Set lis = IsListBox(obj(i))
Set txt = IsTextBox(obj(i))
Set btn = IsCommandButton(obj(i))
Set com = IsComboBox(obj(i))
result = ""
If (Not (lis Is Nothing)) Then
result = "ListBox " & lis.Name
ElseIf (Not (txt Is Nothing)) Then
result = "TexttBox " & txt.Name
ElseIf (Not (btn Is Nothing)) Then
result = "CommandButton " & btn.Name
ElseIf (Not (com Is Nothing)) Then
result = "ComboBox " & com.Name
End If
Debug.Print result
Next i
End Sub
Function IsListBox(obj As Object) As MSForms.ListBox
Set IsListBox = IIf(TypeOf obj Is MSForms.ListBox, obj, Nothing)
End Function
Function IsTextBox(obj As Object) As MSForms.TextBox
Set IsTextBox = IIf(TypeOf obj Is MSForms.TextBox, obj, Nothing)
End Function
Function IsComboBox(obj As Object) As MSForms.ComboBox
Set IsComboBox = IIf(TypeOf obj Is MSForms.ComboBox, obj, Nothing)
End Function
Function IsCommandButton(obj As Object) As MSForms.CommandButton
Set IsCommandButton = IIf(TypeOf obj Is MSForms.CommandButton, obj, Nothing)
End Function
One use for it is a class for handling events in one class.
Private WithEvents intEvents As IntBoxEvents
Private WithEvents decEvents As DecBoxEvents
Private genEvents As Object
Private genControl as OLEobject
Public sub Delegate(ctrl As OLEObject)
set genControl = ctrl
' Code for creating intEvents or decEvents
if .... create intevents.... then set genEvents = new IntEvents ' pseudo code
if .... create decevents.... then set genEvents = new DecEvents ' pseudo code
end sub
I hope this helps others that struggle with casting controls
I have create a Node Object:
Public value As Integer
Public marked As Boolean
Private Sub Class_Initialize()
value = 0
marked = False
End Sub
Then I tried to add some Node Objects to a Collection in a for loop:
Dim inp As Integer
Dim counter As Integer
Dim n As node
Dim arr As Collection
Sub MySub()
inp = InputBox("Insert a number: ")
For counter = 2 To inp
Set n = New node
With n
.value = counter
.marked = False
End With
arr.Add n
Next counter
End Sub
But when I try to run it it only says:
Object variable or With block variable not set (Error 91)
Why is that happening?
You're missing a line before your loop:
Set arr = New Collection
With this code (in excel-vba) I add to a collection a number of items depending on an array.
I use the value of the array as key and the string "NULL" as value for each item added.
Dim Coll As New collection
Dim myArr()
Set Coll = New collection
myArr() = Array("String1", "String2", "String3")
For i = LBound(myArr) To UBound(myArr)
Coll.Add "NULL", myArr(i)
Next i
Now, if I want to change the value of an item, identifying it by the key, I must remove the item and then add an item with same key or is it possible to change the item value?
This below is the only way?
Coll.Remove "String1"
Coll.Add "myString", "String1"
Or is there something like: (I know that doesn't work)
Coll("String1") = "myString"
You can also write a (public) function to make updates to a collection.
public function updateCollectionWithStringValue(coll as Collection, key as string, value as string) as collection
coll.remove key
coll.add value, key
set updateCollectionWithStringValue = coll
end function
You can invoke this function by:
set coll = updateCollectionWithStringValue(coll, "String1","myString")
Then you have a one liner to invoke.
Can't you use the Before argument to fulfill this requirement?
Example:
Option Explicit
Sub TestProject()
Dim myStrings As New Collection
myStrings.Add item:="Text 1"
myStrings.Add item:="Text 2"
myStrings.Add item:="Text 3"
' Print out the content of collection "myStrings"
Debug.Print "--- Initial collection content ---"
PrintCollectionContent myStrings
' Or with the "Call" keyword: Call PrintCollectionContent(myStrings)
Debug.Print "--- End Initial collection content ---"
' Now we want to change "Text 2" into "New Text"
myStrings.Add item:="New Text", Before:=2 ' myStrings will now contain 4 items
Debug.Print "--- Collection content after adding the new content ---"
' Print out the 'in-between' status of collection "myStrings" where we have
' both the new string and the string to be replaced still in.
PrintCollectionContent myStrings
Debug.Print "--- End Collection content after adding the new content ---"
myStrings.Remove 3
' Print out the final status of collection "myStrings" where the obsolete
' item is removed
Debug.Print "--- Collection content after removal of the old content ---"
PrintCollectionContent myStrings
Debug.Print "--- End Collection content after removal of the old content ---"
End Sub
Private Sub PrintCollectionContent(ByVal myColl As Variant)
Dim i as Integer
For i = 1 To myColl.Count()
Debug.Print myColl.Item(i)
Next i
End Sub
Shouldn't this do the job?
Here is a solution where Coll("String1") = "myString" does work.
When you .Add an object to a VBA collection, the object itself is added, not its value. This means you can change the object's properties while it is in the collection. I've created a class module which wraps a single variant in a class object, with .Value as its default property. Save this to a .cls file, then File > Import File in the VBA editor.
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "clsValue"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Compare Database
Option Explicit
Private MyValue As Variant
Property Get Value() As Variant
Attribute Value.VB_UserMemId = 0
Value = MyValue
End Property
Property Let Value(v As Variant)
Attribute Value.VB_UserMemId = 0
MyValue = v
End Property
Now this version of your code works the way you had hoped:
Private Sub clsValue_test()
Dim Coll As New Collection
Dim myArr()
Dim v As Variant
myArr = Array("String1", "String2", "String3")
For Each v In myArr
Coll.Add New clsValue, v
Coll(v) = "NULL"
Next v
Coll("String1") = "myString" ' it works!
For Each v In myArr
Debug.Print v, ": "; Coll(v)
Next v
End Sub
Produces the result:
String1 : myString
String2 : NULL
String3 : NULL
A variant of making a function that deletes the collection item by its key, is implementing it as a VBA Property
Public Property Let CollectionValue(coll As Collection, key As String, value As String)
On Error Resume Next
coll.Remove key
On Error GoTo 0
coll.Add value, key
End Property
Public Property Get CollectionValue(coll As Collection, key As String) As String
CollectionValue = coll(key)
End Property
And Used like this
'Writing
CollectionValue(coll, "Date") = Now()
'Reading
Debug.Print(CollectionValue(coll, "Date"))
By ignoring if key not exists, it can be used to add items as well
just loop the collection and add the new values to a new collection...
function prep_new_collection(my_old_data as collection) as collection
dim col_data_prep as new collection
for i = 1 to my_old_data.count
if my_old_data(i)(0)= "whatever" then
col_data_prep.add array("NULL", my_old_data(i)(1))
else
col_data_prep.add array(my_old_data(i)(0), my_old_data(i)(1))
end if
next i
set prep_new_collection = col_data_prep
end function
I just ran into the same issue an thought to post my solution here for any one who might need it. my solution was to make a class called
EnhancedCollection that has an update function. save this code to a file named EnhancedCollection.cls and then import into your project.
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "EnhancedCollection"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Private data As New Collection
'=================================ADD
If IsMissing(key) Then
If IsMissing(before) Then
If IsMissing(after) Then
data.Add Value
Else
data.Add Value, , , after
End If
Else
data.Add Value, , before
End If
ElseIf key = "TEMP_ITEM" Then
Exit Sub
Else
If IsMissing(before) Then
If IsMissing(after) Then
data.Add Value, key
Else
data.Add Value, key, , after
End If
Else
data.Add Value, key, before
End If
End If
End Sub
'=================================REMOVE
Sub Remove(key As Variant)
data.Remove key
End Sub
'=================================COUNT
Function Count() As Integer
Count = data.Count
End Function
'=================================ITEM
Function Item(key As Variant) As Variant
'This is the default Function of the class
Attribute Item.VB_Description = "returns the item"
Attribute Item.VB_UserMemId = 0
On Error GoTo OnError
If VarType(key) = vbString Or VarType(key) = vbInteger Then
Item = data.Item(key)
End If
Exit Function
OnError:
Item = Null
End Function
'=================================Update
Function Update(key As Variant, Value As Variant) As Variant
On Error GoTo OnError
If VarType(key) = vbString Or VarType(key) = vbInteger Then
data.Add "", "TEMP_ITEM", , key
data.Remove key
data.Add Value, key, "TEMP_ITEM"
data.Remove "TEMP_ITEM"
End If
Exit Function
OnError:
Update = Null
End Function
And as an added benefit, you can always add more functionality.
How do I determine whether an object is a member of a collection in VBA?
Specifically, I need to find out whether a table definition is a member of the TableDefs collection.
Isn't it good enough?
Public Function Contains(col As Collection, key As Variant) As Boolean
Dim obj As Variant
On Error GoTo err
Contains = True
obj = col(key)
Exit Function
err:
Contains = False
End Function
Not exactly elegant, but the best (and quickest) solution i could find was using OnError. This will be significantly faster than iteration for any medium to large collection.
Public Function InCollection(col As Collection, key As String) As Boolean
Dim var As Variant
Dim errNumber As Long
InCollection = False
Set var = Nothing
Err.Clear
On Error Resume Next
var = col.Item(key)
errNumber = CLng(Err.Number)
On Error GoTo 0
'5 is not in, 0 and 438 represent incollection
If errNumber = 5 Then ' it is 5 if not in collection
InCollection = False
Else
InCollection = True
End If
End Function
Your best bet is to iterate over the members of the collection and see if any match what you are looking for. Trust me I have had to do this many times.
The second solution (which is much worse) is to catch the "Item not in collection" error and then set a flag to say the item does not exist.
This is an old question. I have carefully reviewed all the answers and comments, tested the solutions for performance.
I came up with the fastest option for my environment which does not fail when a collection has objects as well as primitives.
Public Function ExistsInCollection(col As Collection, key As Variant) As Boolean
On Error GoTo err
ExistsInCollection = True
IsObject(col.item(key))
Exit Function
err:
ExistsInCollection = False
End Function
In addition, this solution does not depend on hard-coded error values. So the parameter col As Collection can be substituted by some other collection type variable, and the function must still work. E.g., on my current project, I will have it as col As ListColumns.
You can shorten the suggested code for this as well as generalize for unexpected errors.
Here you go:
Public Function InCollection(col As Collection, key As String) As Boolean
On Error GoTo incol
col.Item key
incol:
InCollection = (Err.Number = 0)
End Function
In your specific case (TableDefs) iterating over the collection and checking the Name is a good approach. This is OK because the key for the collection (Name) is a property of the class in the collection.
But in the general case of VBA collections, the key will not necessarily be part of the object in the collection (e.g. you could be using a Collection as a dictionary, with a key that has nothing to do with the object in the collection). In this case, you have no choice but to try accessing the item and catching the error.
I created this solution from the above suggestions mixed with microsofts solution of for iterating through a collection.
Public Function InCollection(col As Collection, Optional vItem, Optional vKey) As Boolean
On Error Resume Next
Dim vColItem As Variant
InCollection = False
If Not IsMissing(vKey) Then
col.item vKey
'5 if not in collection, it is 91 if no collection exists
If Err.Number <> 5 And Err.Number <> 91 Then
InCollection = True
End If
ElseIf Not IsMissing(vItem) Then
For Each vColItem In col
If vColItem = vItem Then
InCollection = True
GoTo Exit_Proc
End If
Next vColItem
End If
Exit_Proc:
Exit Function
Err_Handle:
Resume Exit_Proc
End Function
I have some edit, best working for collections:
Public Function Contains(col As collection, key As Variant) As Boolean
Dim obj As Object
On Error GoTo err
Contains = True
Set obj = col.Item(key)
Exit Function
err:
Contains = False
End Function
For the case when key is unused for collection:
Public Function Contains(col As Collection, thisItem As Variant) As Boolean
Dim item As Variant
Contains = False
For Each item In col
If item = thisItem Then
Contains = True
Exit Function
End If
Next
End Function
this version works for primitive types and for classes (short test-method included)
' TODO: change this to the name of your module
Private Const sMODULE As String = "MVbaUtils"
Public Function ExistsInCollection(oCollection As Collection, sKey As String) As Boolean
Const scSOURCE As String = "ExistsInCollection"
Dim lErrNumber As Long
Dim sErrDescription As String
lErrNumber = 0
sErrDescription = "unknown error occurred"
Err.Clear
On Error Resume Next
' note: just access the item - no need to assign it to a dummy value
' and this would not be so easy, because we would need different
' code depending on the type of object
' e.g.
' Dim vItem as Variant
' If VarType(oCollection.Item(sKey)) = vbObject Then
' Set vItem = oCollection.Item(sKey)
' Else
' vItem = oCollection.Item(sKey)
' End If
oCollection.Item sKey
lErrNumber = CLng(Err.Number)
sErrDescription = Err.Description
On Error GoTo 0
If lErrNumber = 5 Then ' 5 = not in collection
ExistsInCollection = False
ElseIf (lErrNumber = 0) Then
ExistsInCollection = True
Else
' Re-raise error
Err.Raise lErrNumber, mscMODULE & ":" & scSOURCE, sErrDescription
End If
End Function
Private Sub Test_ExistsInCollection()
Dim asTest As New Collection
Debug.Assert Not ExistsInCollection(asTest, "")
Debug.Assert Not ExistsInCollection(asTest, "xx")
asTest.Add "item1", "key1"
asTest.Add "item2", "key2"
asTest.Add New Collection, "key3"
asTest.Add Nothing, "key4"
Debug.Assert ExistsInCollection(asTest, "key1")
Debug.Assert ExistsInCollection(asTest, "key2")
Debug.Assert ExistsInCollection(asTest, "key3")
Debug.Assert ExistsInCollection(asTest, "key4")
Debug.Assert Not ExistsInCollection(asTest, "abcx")
Debug.Print "ExistsInCollection is okay"
End Sub
It requires some additional adjustments in case the items in the collection are not Objects, but Arrays. Other than that it worked fine for me.
Public Function CheckExists(vntIndexKey As Variant) As Boolean
On Error Resume Next
Dim cObj As Object
' just get the object
Set cObj = mCol(vntIndexKey)
' here's the key! Trap the Error Code
' when the error code is 5 then the Object is Not Exists
CheckExists = (Err <> 5)
' just to clear the error
If Err <> 0 Then Call Err.Clear
Set cObj = Nothing
End Function
Source: http://coderstalk.blogspot.com/2007/09/visual-basic-programming-how-to-check.html
It works for me
Public Function contains(col As Collection, key As Variant) As Boolean
For Each element In col
If (element = key) Then
contains = True
Exit Function
End If
Next
contains = False
End Function
Not my code, but I think it's pretty nicely written. It allows to check by the key as well as by the Object element itself and handles both the On Error method and iterating through all Collection elements.
https://danwagner.co/how-to-check-if-a-collection-contains-an-object/
I'll not copy the full explanation since it is available on the linked page. Solution itself copied in case the page eventually becomes unavailable in the future.
The doubt I have about the code is the overusage of GoTo in the first If block but that's easy to fix for anyone so I'm leaving the original code as it is.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'INPUT : Kollection, the collection we would like to examine
' : (Optional) Key, the Key we want to find in the collection
' : (Optional) Item, the Item we want to find in the collection
'OUTPUT : True if Key or Item is found, False if not
'SPECIAL CASE: If both Key and Item are missing, return False
Option Explicit
Public Function CollectionContains(Kollection As Collection, Optional Key As Variant, Optional Item As Variant) As Boolean
Dim strKey As String
Dim var As Variant
'First, investigate assuming a Key was provided
If Not IsMissing(Key) Then
strKey = CStr(Key)
'Handling errors is the strategy here
On Error Resume Next
CollectionContains = True
var = Kollection(strKey) '<~ this is where our (potential) error will occur
If Err.Number = 91 Then GoTo CheckForObject
If Err.Number = 5 Then GoTo NotFound
On Error GoTo 0
Exit Function
CheckForObject:
If IsObject(Kollection(strKey)) Then
CollectionContains = True
On Error GoTo 0
Exit Function
End If
NotFound:
CollectionContains = False
On Error GoTo 0
Exit Function
'If the Item was provided but the Key was not, then...
ElseIf Not IsMissing(Item) Then
CollectionContains = False '<~ assume that we will not find the item
'We have to loop through the collection and check each item against the passed-in Item
For Each var In Kollection
If var = Item Then
CollectionContains = True
Exit Function
End If
Next var
'Otherwise, no Key OR Item was provided, so we default to False
Else
CollectionContains = False
End If
End Function
i used this code to convert array to collection and back to array to remove duplicates, assembled from various posts here (sorry for not giving properly credit).
Function ArrayRemoveDups(MyArray As Variant) As Variant
Dim nFirst As Long, nLast As Long, i As Long
Dim item As Variant, outputArray() As Variant
Dim Coll As New Collection
'Get First and Last Array Positions
nFirst = LBound(MyArray)
nLast = UBound(MyArray)
ReDim arrTemp(nFirst To nLast)
i = nFirst
'convert to collection
For Each item In MyArray
skipitem = False
For Each key In Coll
If key = item Then skipitem = True
Next
If skipitem = False Then Coll.Add (item)
Next item
'convert back to array
ReDim outputArray(0 To Coll.Count - 1)
For i = 1 To Coll.Count
outputArray(i - 1) = Coll.item(i)
Next
ArrayRemoveDups = outputArray
End Function
I did it like this, a variation on Vadims code but to me a bit more readable:
' Returns TRUE if item is already contained in collection, otherwise FALSE
Public Function Contains(col As Collection, item As String) As Boolean
Dim i As Integer
For i = 1 To col.Count
If col.item(i) = item Then
Contains = True
Exit Function
End If
Next i
Contains = False
End Function
I wrote this code. I guess it can help someone...
Public Function VerifyCollection()
For i = 1 To 10 Step 1
MyKey = "A"
On Error GoTo KillError:
Dispersao.Add 1, MyKey
GoTo KeepInForLoop
KillError: 'If My collection already has the key A Then...
count = Dispersao(MyKey)
Dispersao.Remove (MyKey)
Dispersao.Add count + 1, MyKey 'Increase the amount in relationship with my Key
count = Dispersao(MyKey) 'count = new amount
On Error GoTo -1
KeepInForLoop:
Next
End Function