I am trying to make my code compact and easily expendable and now I have bumped into a problem.
I have 18 comboxes which might be more in the future, these should be initialized with an array:
Array_MyFirstDataSet ...
So if I name all my comboboxes with this naming pattern
ComboBox_MyFirstDataSet ...
but I can not figure out how to dynamically assign
ComboBox_MyFirstDataSet.List=Array_MyFirstDataSet
So should I add all the arrays to a dictonary instead of keeping them as independent arrays?
My non working code is below,
Create arrays:
Public Sub initPartslist()
If CPearson.IsArrayEmpty(Settings.Array_Type) Then
Settings.Array_Type = Split("NA,PRT,ASM,SHEET,WELD PRT,WELD ASS,WELD MRG", ",")
End If
If CPearson.IsArrayEmpty(Settings.Array_SpeedSelect) Then
Settings.Array_SpeedSelect = Split("NA,Fresing,Dreiing,Vannskjæring,Dreiing og Fresing,Fresing og Dreiing,Sveising,Montering", ",")
End If
And here I try to add the arrays to the comboboxes
Public Sub initComboBox() 'rowNumber As Integer
Dim cCont As control
Dim cName As String
'All members in Frame_MOM
For Each cCont In MOM.Frame_MOM.Controls
If TypeName(cCont) = "ComboBox" Then
cName = replace(cCont.name, "ComboBox", "Array")
cCont.List = Settings.cName
End If
Next cCont
You are nearly there. It will work if Settings.cName is an array. Like this:
Dim cName(2, 0 to 2)
cName(0, 0) = "John"
cName(0, 1) = 1982
...
cCont.List = Settings.cName
Related
I am writing an application where I bring change history of items from the database and place them on the table using For Each loop. I would, however, like to show in table what information has changed in each edit. Is it possible to compare variables of each item to the variables of next loop in For Each loop?
Something like:
For Each k As Examplemodel In Model
'Find next item on the loop after current one somehow
Dim nextItem = Model.Item(k+1) 'something like this
If k.ItemsName <> nextItem.Itemsname 'if the name has changed in edit
'show result in bold
Else
'show result in normal font weight
End If
Next
Is this possible and if not, what's the best way to achieve this?
You can't do it in a foreach loop directly.
If your Model class have indexers you can easily convert it into a for loop:
If Model.Count > 1 Then
For i as Integer = 0 to Model.Count - 2 ' Note the -2 here !!!
Dim Item As Examplemodel = Model(i)
Dim NextItem As Examplemodel = Model(i + 1)
if Item.ItemsName <> NextItem.ItemsName then
'show result in bold
else
'show result in normal font weight
end if
Next
'show result of NextItem here, since the last item doesn't get shown in the loop
Else
'show result of only item here
End If
If not, you can use a workaround like this:
Dim PrevItem as Examplemodel = Nothing ' Assuming a reference type
For Each k As Examplemodel In Model
If Not IsNothing(PrevItem) AndAlso k.ItemsName <> Prev.Itemsname 'if the name has changed in edit
'show result (of PrevItem!!!) in bold
Else
'show result (of PrevItem!!!) in normal font weight
End If
PrevItem = k
Next
'show result (of PrevItem (currently the last item in Model) in normal font weight
You should use a normal for loop:
Dim numbers() As Integer = New Integer() {1, 2, 4, 8}
Sub Main()
For index As Integer = 0 To numbers.Length - 2
Dim currentInt As Integer = numbers(index)
Dim nextInt As Integer = numbers(index + 1)
Console.WriteLine(currentInt)
Console.WriteLine(nextInt)
Next
End Sub
Another approach to use LINQ Aggregate extension method, which use first item of collection as initial value. So every item will have access to previous one.
Public Class ItemChanges
Public Property Item As ExampleModel
Public Property Changes As New Hash(Of String)
End Class
Public Function Check(previous As ItemChanges, current As ItemChanges) As ItemChanges
If current.Item.Name <> previous.Item.Name Then
current.Changes.Add(Nameof(current.Name))
End
Return current
End Function
' assume model is collection of items
Dim itemWithChanges =
model.Select(Function(m) New ItemChanges With { .Item = m })
.Aggregate(AddressOf(Check))
.ToList()
Then you can use calculated result as you want - every item will have a hash of property names which had changed
If checkedItem.Changes.Contains(Nameof(checkedItem.Item.Name)) Then
' use bold font or different color
End
I have a Collection Class (or rather a dictionary class, in this case) that is used to store a variable amount of edge objects. When I try to populate the Dictionary that holds all the information via loop, the data is continuously overwritten and I cannot seem to figure out why. The code for the class in question follows:
Option Explicit
Private pEdges As New Scripting.Dictionary
Property Get Count() As Long
Count = pEdges.Count
End Property
Property Get EdgeByName(ByVal iName As Variant) As cEdge
Set EdgeByName = pEdges(iName)
End Property
'Would it be better to pass all of the data to this add sub, and create
'the class objects here, rather than creating a temporary class object and
'just passing it along?
Sub Add(ByVal iEdge As cEdge)
Dim Edge As New cEdge
Set Edge = iEdge
pEdges.Add Edge.Name, Edge
End Sub
Sub Remove(ByVal iName As Variant)
pEdges.Remove (iName)
End Sub
Sub RemoveAll()
pEdges.RemoveAll
End Sub
Sub PrintNames()
Dim Key As Variant
For Each Key In pEdges
Debug.Print Key & " - " & pEdges(Key).Name & vbCrLf;
Next
Debug.Print vbdrlf;
End Sub
Sub that generates the Edges object follows:
Sub CalculateEdges(cCavities() As cCavity, dEdges As cEdges)
Dim i As Integer
For i = 1 To UBound(cCavities)
Dim TempEdge As cEdge
Set TempEdge = New cEdge
Dim AdjSize As Integer
AdjSize = cCavities(i).AdjacencySize
If AdjSize> MaxEdges Then MaxEdges = AdjSize
Dim j As Integer
For j = 1 To AdjSize
With TempEdge
'Edge Names are a combination of two node names
.Name = cCavities(i).Name & cCavities(i).Adjacency(j)
'Sets the start node (Object) for the edge
.SetNode cCavities(i), 0
'Sets the end node (Object) for the edge
.SetNode BackGround.NodeByName(cCavities, cCavities(i).Adjacency(j)), 1
'Used later in program
.Value = 0
End With
dEdges.Add TempEdge
dEdges.PrintNames
Next j
Next i
End Sub
The output of the dEdges.PrintNames sub is what I have been using for debugging this (since the Watches window doesn't show the item data of a dictionary).
As the loops go on it prints the Key and the Name Value of the edge object that the key corresponds to. If working correctly, these two strings should be identical. As it is though, every time I add a new edge object to the dictionary, it overwrites the objects for all the previously entered keys. I have the suspicion that this is related to the fact that I create a TempEdge Variable to pass to the Collection Class, but I am not sure.
Example of output:
C1C2 - C1C2
C1C2 - C1C3
C1C3 - C1C3
C1C2 - C1C4
C1C3 - C1C4
C1C4 - C1C4
ETC
This is just one single data point being tested, but let me assure you that all the variables inside the cEdge object are overwritten, not just the name string. It is simply the easiest to check since it is just a string.
As a side note, if there is a way to see the Object stored in the dictionary, similar to the "Watches" window, I would very much like to know how to do it. The entire reason I am even using the temp edge at this point is so I can keep track of what data is going into the dictionary at any given point in the loop.
Second side note, If I can get this working I will most likely switch the cCavities array to a similar collection class. It is not currently one because I cant seem to get them working right.
Moving the Set "TempEdge = New cEdge" into the loop will create a new instance and a new pointer location with every loop while maintaining your collections references to previous pointers.
Sub CalculateEdges(cCavities() As cCavity, dEdges As cEdges)
Dim i As Integer
For i = 1 To UBound(cCavities)
Dim TempEdge As cEdge
Dim AdjSize As Integer
AdjSize = cCavities(i).AdjacencySize
If AdjSize> MaxEdges Then MaxEdges = AdjSize
Dim j As Integer
For j = 1 To AdjSize
Set TempEdge = New cEdge
With TempEdge
'Edge Names are a combination of two node names
.Name = cCavities(i).Name & cCavities(i).Adjacency(j)
'Sets the start node (Object) for the edge
.SetNode cCavities(i), 0
'Sets the end node (Object) for the edge
.SetNode BackGround.NodeByName(cCavities, cCavities(i).Adjacency(j)), 1
'Used later in program
.Value = 0
End With
dEdges.Add TempEdge
dEdges.PrintNames
Next j
Next i
End Sub
I went ahead with the idea to pass along all the data to the add routine, and it seems to have solved the issue. I would still like to know why the method I was using did not work, though, so please feel free to comment or answer with regards to that.
The solution was to change the cEdges.Add Sub to accept all the individual parameters that were once passed to the temporary edge variable:
Sub Add(ByVal iName As String, iNode1 As cCavity, iNode2 As cCavity, iValue As Integer)
Dim Edge As New cEdge
With Edge
.Name = iName
.SetNode iNode1, 0
.SetNode iNode2, 1
.Value = iValue
End With
pEdges.Add Edge.Name, Edge
End Sub
This changes the populating loop to look like:
Sub CalculateEdges(cCavities() As cCavity, dEdges As cEdges)
Dim i As Integer
For i = 1 To UBound(cCavities)
Dim AdjSize As Integer
AdjSize = cCavities(i).AdjacencySize
If AdjSize > MaxEdges Then MaxEdges = AdjSize
Dim j As Integer
For j = 1 To AdjSize
dEdges.Add cCavities(i).Name & cCavities(i).Adjacency(j), cCavities(i), BackGround.NodeByName(cCavities, cCavities(i).Adjacency(j)), 0
dEdges.PrintNames
Next j
Next i
End Sub
This code, especially the .Add line, could be cleaned up. I will most likely do that, but this is fine for now.
EDIT: Upon further research and a bit more trial and error, I have discovered the reason for the data being overwritten. The Set keyword only creates a pointer to the original value, effectively making my above code have one object, the TempEdge variable, and a whole bunch of different heads that pointed to it. That is why when the Temp edge was edited, all the subsequent heads changes.
I have a slicer called 'Slicer_HeaderTitle'. I simply need to be able to dim a variable in VBA with the value of the selected element. I'll only have one element selected at a time.
I've had a lot of problems with selecting and de-selecting elements from my slicer dynamically via VBA, since my pivot table is connected to an external data-source. I don't know if this is relevant for this exact example, but this table is connected to the same external data-source.
I used to have a single line of code, which could return this value, but all i could find now requires you loop through each element in the slicer and check if it's selected or not. I hope to avoid this, since I only have 1 selected element at a time.
' This is what I'm trying to achieve.
Dim sValue as String
sValue = ActiveWorkbook.SlicerCaches("Slicer_HeaderTitle").VisibleSlicerItems.Value
msgbox(sValue)
'Returns: "Uge 14 - 2016 (3. Apr - 9. Apr)"
Current Status:
This is what i did:
Public Function GetSelectedSlicerItems(SlicerName As String) As String
Dim SL As SlicerCacheLevel
Dim sI As SlicerItem
Set SL = ActiveWorkbook.SlicerCaches(SlicerName).SlicerCacheLevels(1)
For Each sI In SL.SlicerItems
If sI.Selected = True Then
GetSelectedSlicerItems = (sI.Value)
End If
Next
End Function
Dim sValue As String
sValue = GetSelectedSlicerItems("Slicer_HeaderTitle")
Thanks to Doktor OSwaldo for helping me a lot!
Ok to find the error, we will take a step back, delete my function and try Looping through the items:
Dim sC As SlicerCache
Dim SL As SlicerCacheLevel
Dim sI As SlicerItem
Set sC = ActiveWorkbook.SlicerCaches("Slicer_Dates_Hie")
Set SL = sC.SlicerCacheLevels(1)
For Each sI In SL.SlicerItems
sC.VisibleSlicerItemsList = Array(sI.Name)
Next
I would like to put in my two cents. The set of visible slicer items may be shrunk by both independent actions:
User selection of items in slicer A. To capture those items, use .Selected method.
Selection of items in slicer B which in consequence shrinks the list of slicer A items. To capture those items, use .HasData method.
Note that you may see only say two items of Slicer_Products (apples, bananas) because some other slicer Slicer_Product_Type has active filter on fruits. The method sI.Selected would still return the whole list of products apples, bananas, carrots...
If you want both limitations to be in place then make intersection of both sets. I have modified TobiasKnudsen code (excellent answer!) to return the list of items shrunk by both above limitations. If sI.Selected = True And sI.HasData = True Then is the key line in this code.
Option Explicit
Sub TestExample()
Dim MyArr() As Variant
MyArr = ArrayListOfSelectedAndVisibleSlicerItems("Slicer_A")
'now variable MyArr keeps all items in an array
End Sub
Public Function ArrayListOfSelectedAndVisibleSlicerItems(MySlicerName As String) As Variant
'This function returns an array of the limited set of items in Slicer A
'Limitation is due to both:
'(1) direct selection of items by user in slicer A
'(2) selection of items in slicer B which in consequence limits the number of items in slicer A
Dim ShortList() As Variant
Dim i As Integer: i = 0 'for iterate
Dim sC As SlicerCache
Dim sI As SlicerItem 'for iterate
Set sC = ThisWorkbook.Application.ActiveWorkbook.SlicerCaches(MySlicerName)
For Each sI In sC.SlicerItems
If sI.Selected = True And sI.HasData = True Then 'Here is the condition!!!
'Debug.Print sI.Name
ReDim Preserve ShortList(i)
ShortList(i) = sI.Value
i = i + 1
End If
Next sI
ArrayListOfSelectedAndVisibleSlicerItems = ShortList
End Function
Sub Demo()
Dim i As Integer
With ActiveWorkbook.SlicerCaches("Slicer_Country")
For i = 1 To .SlicerItems.Count
If .SlicerItems(i).Selected Then
Sheets("Pivot Sheet").Range("I" & i) = SlicerSelections & " " & .SlicerItems(i).Value
End If
Next i
End With
End sub
This is how I managed to identify the selected element on a slicer.
The answer by TobiasKnudsen above did not work for me as I got an error stating the data source needed to be an OLAP source.
My data is an excel table and this is the code that worked:
Dim val as Boolean
val = ThisWorkbook.SlicerCaches("Slicer_MYSLICER").VisibleSlicerItems.Item("CS").HasData
In my case, the slicer had only 3 items so I repeated the line above with a different string in item()
So, where val was true, that was the item that was currently selected.
I have a large window with a little under 200 controls/variables to worry about. Many of them are similar, so I am wondering if instead of repeatedly calling each one individually I can concatenate their names.
I'll make an example:
I have 5 pieces of data that I'm worried about: Red, Orange, Yellow, Green, Blue.
Each one of these will have a label that needs to be made visible, a textbox that needs to be made visible, and a string that contains the text in the textbox:
lblRed.Visible = True
txtRed.Visible = True
strRed = txtRed.Text
Instead of listing this for every one of those 5 pieces of data, is there a way that I could make some sort of array to loop through that could concatenate these variable names?
Dim list As New List(Of String)(New String() {"Red", "Orange", "Yellow", "Green", "Blue"})
Dim i As Integer = 0
Do while i < list.count
lbl + list(i) + .Visible = True
txt + list(i) + .Visible = True
str + list(i) = txt + list(i) + .Text
i = i+1
Loop
I know that the above code doesn't work, but I wanted to give you the basic idea of what I wanted to do. Does this look feasible?
http://msdn.microsoft.com/en-us/library/7e4daa9c(v=vs.71).aspx
Using the controls collection:
Dim i As Integer
i = 1
Me.Controls("Textbox" & i).Text = "TEST"
so
Me.controls("lbl" & list(i)).Visible = true
Keep in mind that when concatenating items, '+' will work on strings and not integers. You might want to always use '&' when concatenating
Another way is to use a select-case block for each type of control. Something like this:
Private Sub EnableControls()
For Each c As Control In Me.Controls
Select Case c.GetType
Case GetType(TextBox)
c.Visible = True
Select Case c.Name.Substring(3)
Case "Red"
strRed = c.Text
Case "Orange"
strOrange = c.Text
Case "Yellow"
'and so on
End Select
Case GetType(Label)
c.Visible = True
End Select
Next
End Sub
Check out the information here:
http://msdn.microsoft.com/en-us/library/axt1ctd9.aspx
I'm sure someone may find something slightly more eloquent than this, but this should achieve your desired result. You'll need the below import:
Imports System.Reflection
If you use properties to access your variables, you can use reflection to grab them by name:
'Define these with getters/setters/private vars
Private Property strRed as String
Private Property strOrange as String
Private Property strYellow as String
Private Property strGreen as String
Private Property strBlue as String
For each color as String in list
If Me.Controls.Count > 1 Then
'Should really check for existence here, but it's just an example.
Me.Controls("lbl" & color).Visible = True
Dim tbx as TextBox = Me.Controls("txt" & color)
tbx.Visible = True
Dim propInfo as PropertyInfo = Me.GetType.GetProperty("str" & color)
propInfo.SetValue(Me, tbx.Text, Nothing)
End If
Next
Does VBA have dictionary structure? Like key<>value array?
Yes.
Set a reference to MS Scripting runtime ('Microsoft Scripting Runtime'). As per #regjo's comment, go to Tools->References and tick the box for 'Microsoft Scripting Runtime'.
Create a dictionary instance using the code below:
Set dict = CreateObject("Scripting.Dictionary")
or
Dim dict As New Scripting.Dictionary
Example of use:
If Not dict.Exists(key) Then
dict.Add key, value
End If
Don't forget to set the dictionary to Nothing when you have finished using it.
Set dict = Nothing
VBA has the collection object:
Dim c As Collection
Set c = New Collection
c.Add "Data1", "Key1"
c.Add "Data2", "Key2"
c.Add "Data3", "Key3"
'Insert data via key into cell A1
Range("A1").Value = c.Item("Key2")
The Collection object performs key-based lookups using a hash so it's quick.
You can use a Contains() function to check whether a particular collection contains a key:
Public Function Contains(col As Collection, key As Variant) As Boolean
On Error Resume Next
col(key) ' Just try it. If it fails, Err.Number will be nonzero.
Contains = (Err.Number = 0)
Err.Clear
End Function
Edit 24 June 2015: Shorter Contains() thanks to #TWiStErRob.
Edit 25 September 2015: Added Err.Clear() thanks to #scipilot.
VBA does not have an internal implementation of a dictionary, but from VBA you can still use the dictionary object from MS Scripting Runtime Library.
Dim d
Set d = CreateObject("Scripting.Dictionary")
d.Add "a", "aaa"
d.Add "b", "bbb"
d.Add "c", "ccc"
If d.Exists("c") Then
MsgBox d("c")
End If
An additional dictionary example that is useful for containing frequency of occurence.
Outside of loop:
Dim dict As New Scripting.dictionary
Dim MyVar as String
Within a loop:
'dictionary
If dict.Exists(MyVar) Then
dict.Item(MyVar) = dict.Item(MyVar) + 1 'increment
Else
dict.Item(MyVar) = 1 'set as 1st occurence
End If
To check on frequency:
Dim i As Integer
For i = 0 To dict.Count - 1 ' lower index 0 (instead of 1)
Debug.Print dict.Items(i) & " " & dict.Keys(i)
Next i
Building off cjrh's answer, we can build a Contains function requiring no labels (I don't like using labels).
Public Function Contains(Col As Collection, Key As String) As Boolean
Contains = True
On Error Resume Next
err.Clear
Col (Key)
If err.Number <> 0 Then
Contains = False
err.Clear
End If
On Error GoTo 0
End Function
For a project of mine, I wrote a set of helper functions to make a Collection behave more like a Dictionary. It still allows recursive collections. You'll notice Key always comes first because it was mandatory and made more sense in my implementation. I also used only String keys. You can change it back if you like.
Set
I renamed this to set because it will overwrite old values.
Private Sub cSet(ByRef Col As Collection, Key As String, Item As Variant)
If (cHas(Col, Key)) Then Col.Remove Key
Col.Add Array(Key, Item), Key
End Sub
Get
The err stuff is for objects since you would pass objects using set and variables without. I think you can just check if it's an object, but I was pressed for time.
Private Function cGet(ByRef Col As Collection, Key As String) As Variant
If Not cHas(Col, Key) Then Exit Function
On Error Resume Next
err.Clear
Set cGet = Col(Key)(1)
If err.Number = 13 Then
err.Clear
cGet = Col(Key)(1)
End If
On Error GoTo 0
If err.Number <> 0 Then Call err.raise(err.Number, err.Source, err.Description, err.HelpFile, err.HelpContext)
End Function
Has
The reason for this post...
Public Function cHas(Col As Collection, Key As String) As Boolean
cHas = True
On Error Resume Next
err.Clear
Col (Key)
If err.Number <> 0 Then
cHas = False
err.Clear
End If
On Error GoTo 0
End Function
Remove
Doesn't throw if it doesn't exist. Just makes sure it's removed.
Private Sub cRemove(ByRef Col As Collection, Key As String)
If cHas(Col, Key) Then Col.Remove Key
End Sub
Keys
Get an array of keys.
Private Function cKeys(ByRef Col As Collection) As String()
Dim Initialized As Boolean
Dim Keys() As String
For Each Item In Col
If Not Initialized Then
ReDim Preserve Keys(0)
Keys(UBound(Keys)) = Item(0)
Initialized = True
Else
ReDim Preserve Keys(UBound(Keys) + 1)
Keys(UBound(Keys)) = Item(0)
End If
Next Item
cKeys = Keys
End Function
The scripting runtime dictionary seems to have a bug that can ruin your design at advanced stages.
If the dictionary value is an array, you cannot update values of elements contained in the array through a reference to the dictionary.
Yes. For VB6, VBA (Excel), and VB.NET
All the others have already mentioned the use of the scripting.runtime version of the Dictionary class. If you are unable to use this DLL you can also use this version, simply add it to your code.
https://github.com/VBA-tools/VBA-Dictionary/blob/master/Dictionary.cls
It is identical to Microsoft's version.
If by any reason, you can't install additional features to your Excel or don't want to, you can use arrays as well, at least for simple problems.
As WhatIsCapital you put name of the country and the function returns you its capital.
Sub arrays()
Dim WhatIsCapital As String, Country As Array, Capital As Array, Answer As String
WhatIsCapital = "Sweden"
Country = Array("UK", "Sweden", "Germany", "France")
Capital = Array("London", "Stockholm", "Berlin", "Paris")
For i = 0 To 10
If WhatIsCapital = Country(i) Then Answer = Capital(i)
Next i
Debug.Print Answer
End Sub
VBA can use the dictionary structure of Scripting.Runtime.
And its implementation is actually a fancy one - just by doing myDict(x) = y, it checks whether there is a key x in the dictionary and if there is not such, it even creates it. If it is there, it uses it.
And it does not "yell" or "complain" about this extra step, performed "under the hood". Of course, you may check explicitly, whether a key exists with Dictionary.Exists(key). Thus, these 5 lines:
If myDict.exists("B") Then
myDict("B") = myDict("B") + i * 3
Else
myDict.Add "B", i * 3
End If
are the same as this 1 liner - myDict("B") = myDict("B") + i * 3. Check it out:
Sub TestMe()
Dim myDict As Object, i As Long, myKey As Variant
Set myDict = CreateObject("Scripting.Dictionary")
For i = 1 To 3
Debug.Print myDict.Exists("A")
myDict("A") = myDict("A") + i
myDict("B") = myDict("B") + 5
Next i
For Each myKey In myDict.keys
Debug.Print myKey; myDict(myKey)
Next myKey
End Sub
You can access a non-Native HashTable through System.Collections.HashTable.
HashTable
Represents a collection of key/value pairs that are organized based on
the hash code of the key.
Not sure you would ever want to use this over Scripting.Dictionary but adding here for the sake of completeness. You can review the methods in case there are some of interest e.g. Clone, CopyTo
Example:
Option Explicit
Public Sub UsingHashTable()
Dim h As Object
Set h = CreateObject("System.Collections.HashTable")
h.Add "A", 1
' h.Add "A", 1 ''<< Will throw duplicate key error
h.Add "B", 2
h("B") = 2
Dim keys As mscorlib.IEnumerable 'Need to cast in order to enumerate 'https://stackoverflow.com/a/56705428/6241235
Set keys = h.keys
Dim k As Variant
For Each k In keys
Debug.Print k, h(k) 'outputs the key and its associated value
Next
End Sub
This answer by #MathieuGuindon gives plenty of detail about HashTable and also why it is necessary to use mscorlib.IEnumerable (early bound reference to mscorlib) in order to enumerate the key:value pairs.