Background
I just read a comment on this question that states that Redim Preserve is expensive and should be avoided. I use Redim Preserve in many scenarios, let us say for example to save field names from a PT that meet some specific criteria to use them later on with an API for Access/Selenium/XlWings,etc. where I need to access the elements in the array at different times, thus not looping in the original sheet(s) where PT(s) are; I use them to save data that came outside Excel too. This is to save the time to redo verification/processes and everything that was considered by saving the array in the first place.
Research/thoughts
I have seen that a similar question was asked at VB.net where they suggest List(Of Variable) but I do not think this may be achieved within Excel. I Erase them once they are not longer needed too. In addition, where it is possible, I try to use dictionaries instead of arrays, but it may not be always the case where it is easier to go by index numbers and there is a need for array and not dictionaries. I was thinking that I may be able to create a sheet with the specified items instead of saving them to an array, but I do not see the benefit of doing so in terms of memory saving.
Question
What would be the best alternative to Redim Preserve in VBA?
The intent of Ben's comment is that you should avoid excessive use of Preserve.
Where Arrays are a good design choice, you can and should use them. This is especially true when extracting data from an Excel sheet.
So, how to avoid excessive use of Preserve?
The need to Redim Preserve implies you are collecting data into an array, usually in a loop. Redim without Preserve is pretty fast.
If you have sufficient info, calculate the required array size and ReDim it as that size once
If you don't have that info, Redim it to an oversize dimension. Redim Preserve to the actual size once, after the loop
If you must Redim Preserve in the loop, do it infrequently in large chunks
Beware of premature optimisation. If it works fast enough for your needs, maybe just leave it as is
Update for 20 May 2022. An updated version of the class below can be found at
https://github.com/FullValueRider/WCollection
This update has a more extensive collection of methods and is also available as a 32 bit or 64 bit ActiveX.dll (thanks to twinBasic). There are currently 148 passing tests so the problems of things not working should hopefully be avoided.
Please leave any further comments or requests for updates as an issue on the github page.
===============================================
A collection is a good way to go but the default collection is a bit limited.
You may wish to use a wrapped collection which gives you more flexibility.
Class WCollection (but its easy to change the name to List if you prefer)
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "WCollection"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
'Rubberduck annotations
'#PredeclaredId
'#Exposed
Option Explicit
'#ModuleDescription("A wrapper for the collection object to add flexibility")
Private Type State
Coll As Collection
End Type
Private s As State
Private Sub Class_Initialize()
Set s.Coll = New Collection
End Sub
Public Function Deb() As WCollection
With New WCollection
Set Deb = .ReadyToUseInstance
End With
End Function
Friend Function ReadyToUseInstance() As WCollection
Set ReadyToUseInstance = Me
End Function
Public Function NewEnum() As IEnumVARIANT
Set NewEnum = s.Coll.[_NewEnum]
End Function
Public Function Add(ParamArray ipItems() As Variant) As WCollection
Dim myItem As Variant
For Each myItem In ipItems
s.Coll.Add myItem
Next
Set Add = Me
End Function
Public Function AddRange(ByVal ipIterable As Variant) As WCollection
Dim myitem As Variant
For Each myitem In ipIterable
s.Coll.Add myitem
Next
Set AddRange = Me
End Function
Public Function AddString(ByVal ipString As String) As WCollection
Dim myIndex As Long
For myIndex = 1 To Len(ipString)
s.Coll.Add VBA.Mid$(ipString, myIndex, 1)
Next
End Function
Public Function Clone() As WCollection
Set Clone = WCollection.Deb.AddRange(s.Coll)
End Function
'#DefaultMember
Public Property Get Item(ByVal ipIndex As Long) As Variant
If VBA.IsObject(s.Coll.Item(ipIndex)) Then
Set Item = s.Coll.Item(ipIndex)
Else
Item = s.Coll.Item(ipIndex)
End If
End Property
Public Property Let Item(ByVal ipIndex As Long, ByVal ipItem As Variant)
s.Coll.Add ipItem, after:=ipIndex
s.Coll.Remove ipIndex
End Property
Public Property Set Item(ByVal ipindex As Long, ByVal ipitem As Variant)
s.Coll.Add ipitem, after:=ipindex
s.Coll.Remove ipindex
End Property
Public Function HoldsItem(ByVal ipItem As Variant) As Boolean
HoldsItem = True
Dim myItem As Variant
For Each myItem In s.Coll
If myItem = ipItem Then Exit Function
Next
HoldsItem = False
End Function
Public Function Join(Optional ByVal ipSeparator As String) As String
If TypeName(s.Coll.Item(1)) <> "String" Then
Join = "Items are not string type"
Exit Function
End If
Dim myStr As String
Dim myItem As Variant
For Each myItem In s.Coll
If Len(myStr) = 0 Then
myStr = myItem
Else
myStr = myStr & ipSeparator
End If
Next
End Function
Public Function Reverse() As WCollection
Dim myW As WCollection
Set myW = WCollection.Deb
Dim myIndex As Long
For myIndex = LastIndex To FirstIndex Step -1
myW.Add s.Coll.Item(myIndex)
Next
Set Reverse = myW
End Function
Public Function HasItems() As Boolean
HasItems = s.Coll.Count > 0
End Function
Public Function HasNoItems() As Boolean
HasNoItems = Not HasItems
End Function
Public Function Indexof(ByVal ipItem As Variant, Optional ipIndex As Long = -1) As Long
Dim myIndex As Long
For myIndex = IIf(ipIndex = -1, 1, ipIndex) To s.Coll.Count
If ipItem = s.Coll.Item(myIndex) Then
Indexof = myIndex
Exit Function
End If
Next
End Function
Public Function LastIndexof(ByVal ipItem As Variant, Optional ipIndex As Long = -1) As Long
Dim myIndex As Long
For myIndex = LastIndex To IIf(ipIndex = -1, 1, ipIndex) Step -1
If ipItem = s.Coll.Item(myIndex) Then
LastIndexof = myIndex
Exit Function
End If
Next
LastIndexof = -1
End Function
Public Function LacksItem(ByVal ipItem As Variant) As Boolean
LacksItem = Not HoldsItem(ipItem)
End Function
Public Function Insert(ByVal ipIndex As Long, ByVal ipItem As Variant) As WCollection
s.Coll.Add ipItem, before:=ipIndex
Set Insert = Me
End Function
Public Function Remove(ByVal ipIndex As Long) As WCollection
s.Coll.Remove ipIndex
Set Remove = Me
End Function
Public Function FirstIndex() As Long
FirstIndex = 1
End Function
Public Function LastIndex() As Long
LastIndex = s.Coll.Count
End Function
Public Function RemoveAll() As WCollection
Dim myIndex As Long
For myIndex = s.Coll.Count To 1 Step -1
Remove myIndex
Next
Set RemoveAll = Me
End Function
Public Property Get Count() As Long
Count = s.Coll.Count
End Property
Public Function ToArray() As Variant
Dim myarray As Variant
ReDim myarray(0 To s.Coll.Count - 1)
Dim myItem As Variant
Dim myIndex As Long
myIndex = 0
For Each myItem In s.Coll
If VBA.IsObject(myItem) Then
Set myarray(myIndex) = myItem
Else
myarray(myIndex) = myItem
End If
myIndex = myIndex + 1
Next
ToArray = myarray
End Function
Public Function RemoveFirstOf(ByVal ipItem As Variant) As WCollection
Set RemoveFirstOf = Remove(Indexof(ipItem))
Set RemoveFirstOf = Me
End Function
Public Function RemoveLastOf(ByVal ipItem As Variant) As WCollection
Set RemoveLastOf = Remove(LastIndexof(ipItem))
Set RemoveLastOf = Me
End Function
Public Function RemoveAnyOf(ByVal ipItem As Variant) As WCollection
Dim myIndex As Long
For myIndex = LastIndex To FirstIndex Step -1
If s.Coll.Item(myIndex) = ipItem Then Remove myIndex
Next
Set RemoveAnyOf = Me
End Function
Public Function First() As Variant
If VBA.IsObject(s.Coll.Item(FirstIndex)) Then
Set First = s.Coll.Item(FirstIndex)
Else
First = s.Coll.Item(FirstIndex)
End If
End Function
Public Function Last() As Variant
If VBA.IsObject(s.Coll.Item(LastIndex)) Then
Set Last = s.Coll.Item(LastIndex)
Else
Last = s.Coll.Item(LastIndex)
End If
End Function
Public Function Enqueue(ByVal ipItem As Variant) As WCollection
Add ipItem
Set Enqueue = Me
End Function
Public Function Dequeue() As Variant
If VBA.IsObject(s.Coll.Item(FirstIndex)) Then
Set Dequeue = s.Coll.Item(FirstIndex)
Else
Dequeue = s.Coll.Item(FirstIndex)
End If
Remove 0
End Function
Public Function Push(ByVal ipitem As Variant) As WCollection
Add ipitem
Set Push = Me
End Function
Public Function Pop(ByVal ipitem As Variant) As Variant
If VBA.IsObject(s.Coll.Item(FirstIndex)) Then
Set Pop = s.Coll.Item(FirstIndex)
Else
Pop = s.Coll.Item(FirstIndex)
End If
Remove s.Coll.Count
End Function
Public Function Peek(ByVal ipIndex As Long) As Variant
If VBA.IsObject(s.Coll.Item(FirstIndex)) Then
Set Peek = s.Coll.Item(FirstIndex)
Else
Peek = s.Coll.Item(FirstIndex)
End If
End Function
The custom collection shown in another answer looks like a helpful tool. Another one I recently came across is the BetterArray class, found here. Rather than extending the built-in collection, it extends the built-in array. I posted an answer reviewing it and a couple of other options (the ArrayList, and expansion in chunks) here.
A Collection of Array Rows
One other approach is to use a 1d array for each row of data, and add rows into a collection. When done, the result can be dumped into a 2d array. With a function for making the conversion on hand, the process can be convenient and reasonably efficient.
Function ArrayFromRowCollection(source As Collection) As Variant
'Convert a collection of 1d array rows to a 2d array
'The return array will have the max number of columns found in any row (if inconsistent, a warning is printed)
'Any non-array values in the collection will be entered in the first column of the return array (with warning printed)
'Any objects or multidimensional arrays in the collection will cause an error
Dim sourceCount As Long: sourceCount = source.Count
If sourceCount > 0 Then
'Scan for the max column count across all rows; wrap non-arrays in an array with a warning
Dim itmRow As Variant, itmIndex As Long
Dim arrayBound As Long, tempBound As Long, inconsistentBounds As Boolean
For Each itmRow In source
itmIndex = itmIndex + 1
If VarType(itmRow) < vbArray Then 'An array has a vartype of at least the vbArray constant (8192)
source.Add Array(itmRow), , itmIndex
source.Remove itmIndex + 1 'Wrap non-array element in 1d array so it is in the expected format for later
Debug.Print "ArrayFromRowCollection Warning: Non-array item found and entered in first array column (item " & itmIndex & ")"
Else
tempBound = UBound(itmRow)
If arrayBound <> tempBound Then
If itmIndex > 1 Then inconsistentBounds = True 'This prompts a warning below
If tempBound > arrayBound Then arrayBound = tempBound 'Take the new larger bound, in search of the max
End If
End If
Next
If inconsistentBounds Then Debug.Print "ArrayFromRowCollection Warning: Inconsistent column counts found."
'Create 2d array
Dim i As Long, j As Long
Dim returnArray() As Variant
ReDim returnArray(sourceCount - 1, arrayBound)
For Each itmRow In source
For j = 0 To UBound(itmRow)
returnArray(i, j) = itmRow(j)
Next
i = i + 1
Next
ArrayFromRowCollection = returnArray
Else
ArrayFromRowCollection = Array() 'Empty array for empty collection
End If
End Function
A quick demo, creating an array of data from a directory.
Sub GatherDirectoryInfo()
'Gather directory info in a collection of 1d array rows
Dim tempDir As String, dirPath As String, tempFull As String
dirPath = "C:" & Application.PathSeparator
tempDir = Dir(dirPath, vbDirectory) 'This gets basic files and folders (just the first with this call)
Dim tempCollection As Collection: Set tempCollection = New Collection
tempCollection.Add Array("Parent Folder", "Name", "Type", "File Size", "Last Modified") 'Headers
Do While tempDir <> ""
tempFull = dirPath & tempDir
tempCollection.Add Array(dirPath, tempDir, IIf(GetAttr(tempFull) And vbDirectory, "Folder", ""), Round(FileLen(tempFull) / 1024, 0) & " kb", FileDateTime(tempFull))
tempDir = Dir()
Loop
'Transfer collection to 2d array
Dim DirArray As Variant
DirArray = ArrayFromRowCollection(tempCollection)
End Sub
I would like to set a Get property for a class in vba to be an array. How do I do this.
in the class module
Dim pdbCGX As Double
Dim pdbCGY As Double
Dim pdbCGZ As Double
Public Property Get TheCGv() As Double
TheCGv(0) = pdbCGX
TheCGv(1) = pdbCGY
TheCGv(2) = pdbCGZ
End Property
'allocation of data in a sub in the class
pdbCGX = CDbl(extracteddata1)
pdbCGY = CDbl(extracteddata2)
pdbCGZ = CDbl(extracteddata3)
I would suggest to do it like that
Option Explicit
Dim pdbCGX As Double
Dim pdbCGY As Double
Dim pdbCGZ As Double
Public Property Get TheCGv() As Variant
Dim v(0 To 2) As Double
v(0) = pdbCGX
v(1) = pdbCGY
v(2) = pdbCGZ
TheCGv = v
End Property
If you want to return an array with data type double your code could look like that
Option Explicit
Dim pdbCGX As Double
Dim pdbCGY As Double
Dim pdbCGZ As Double
Public Property Get TheCGv() As Double()
Dim v(0 To 2) As Double
v(0) = pdbCGX
v(1) = pdbCGY
v(2) = pdbCGZ
TheCGv = v
End Property
A better solution to this problem is to not use an array, but instead put a scripting.Dictionary inside the class and also set up an enumeration to ensure that reading and writing to the scripting .Dictionary is strongly typed.
The code below is a wrapper class for a Scripting.dictionary to which I've added an Enum based on your post above.
Option Explicit
' Strongly typed wrapper for the Scripting.Dictionary
' Replace KeyType with the Type for the Key to be used -> done using pdb
' Replace ValueType with the Type for the Values to be used - done using Double
Public Enum pdb
CGX
CGY
CGZ
End Enum
Private Type State
Host As Scripting.Dictionary
End Type
Private s As State
Private Sub Class_Initialize()
'Set s.Host = CreateObject("Scripting.Dictionary")
Set s.Host = New Scripting.Dictionary
End Sub
'#Description("Add: Adds a new key/item pair to a Dictionary object").
Public Sub Add(ByVal Key As pdb, ByVal Value As Double)
s.Host.Add Key, Value
End Sub
'#Description("Count: Returns the number of key/item pairs in a Dictionary object.")
Public Function Count() As Long
Count = s.Host.Count
End Function
'#Description("CompareMode: Sets or returns the comparison mode for comparing keys in a Dictionary object.")
Public Property Get CompareMode() As Scripting.CompareMethod
CompareMode = s.Host.CompareMode
End Property
Public Property Let CompareMode(ByVal Compare As Scripting.CompareMethod)
s.Host.CompareMode = Compare
End Property
'#Description("Exists Returns a Boolean value that indicates whether a specified key exists in the Dictionary object.)
Public Function Exists(ByVal Key As pdb) As Boolean
Exists = s.Host.Exists(Key)
End Function
'#Description("Item: Get or returns the value of an item in a Dictionary object.")
'#DefaultMember
Public Property Get Item(ByVal Key As pdb)
Item = s.Host(Key)
End Property
' Delete Let or Set depending if Value is a primitive or object type
Public Property Let Item(ByVal Key As pdb, ByVal Value As Double)
s.Host(Key) = Value
End Property
Public Property Set Item(ByVal Key As pdb, ByVal Value As Double)
Set s.Host(Key) = Value
End Property
'#Description("'Items: Returns an array of all the items in a Dictionary object.")
Public Function Items() As Variant
Items = s.Host.Items
End Function
'#Description("Key Sets a new key value for an existing key value in a Dictionary object.")
Public Sub Key(ByVal OldKey As pdb, ByVal NewKey As pdb)
s.Host.Key(OldKey) = NewKey
End Sub
'#Description("Keys Returns an array of all the keys in a Dictionary object.")
Public Function Keys() As Variant
Keys = s.Host.Keys()
End Function
'#Description("Remove Removes one specified key/item pair from the Dictionary object.")
Public Sub Remove(ByVal Key As pdb)
s.Host.Remove (Key)
End Sub
'#Description("RemoveAll: Removes all the key/item pairs in the Dictionary object.")
Public Sub RemoveAll()
s.Host.RemoveAll
End Sub
If you do require an array, for example you are putting values back into Excel, then the values in the scripting dictionary can be obtained as an Array from the .Items method.
I have following json data:
{
"cgFinishing": {
"a3colorfn": [{
"type": "Cacah",
"kode": "CCH"
},
{
"type": "Cutting",
"kode": "CUT"
}
]
}
}
And my JSON Class:
Public Class A3colorfn
Public Property type As String
Public Property kode As String
End Class
Public Class CgFinishing
Public Property a3colorfn As A3colorfn()
End Class
Public Class CGSave
Public Property cgFinishing As CgFinishing
End Class
I want to write a method in VB.NET that pull values from this JSON array using JSON.NET. This code works for me:
Public Sub fillCBfromJson(ByVal cb As ComboBox, json As Object, Optional ByVal value As String = "", Optional display As String = "")
....
End Sub
But I'd like to replace json As Object with something that are more specific, because I'd like to retrieve the count of items in the array (something like Count or GetLength, I cannot expose those property with Object type)
For your reference this code works for me...
Dim count As Integer = jsonObj.cgFinishing.a3colorfn.GetLength(0)
But I have no idea to turn it as a method.
Any help is appreciated.
More code listing:
Private Sub PublishDigital_Load(sender As Object, e As System.EventArgs) Handles MyBase.Load
jsonPath = Application.StartupPath + "\Addons\CG_Tools\cgSave.json"
jsonObj = JsonConvert.DeserializeObject(Of CGSave)(File.ReadAllText(jsonPath))
initfinishingA3()
End Sub
Public Sub initfinishingA3() 'I want to make this as a method, so I'll only need to input the Array object as argument.
Dim cbdata As Object = jsonObj.cgFinishing.a3colorfn '<- I want to put this line as argument instead
Dim count As Integer = jsonObj.cgFinishing.a3colorfn.GetLength(0)
Dim myCb As New List(Of CheckBox)
For Each cur In cbdata
Dim cb = New CheckBox()
tb_finishinga3.Controls.Add(cb)
Dim txt As JObject = JsonConvert.DeserializeObject(Of JObject)(JsonConvert.SerializeObject(cur))
...
cb.Text = txt("type")
...
Next
End Sub
Following method I wrote does not work..
Public Sub fillTabwithCB(ByVal cbdata As JArray, XOffset As Integer, YOffset As Integer, maxRow As Integer)
Dim count As Integer = cbdata.Count
Dim loopIndex As Integer
Dim i As Integer = 0
Dim myCb As New List(Of CheckBox)
For Each cur In cbdata
Dim cb = New CheckBox()
tb_finishinga3.Controls.Add(cb)
Dim txt As JObject = JsonConvert.DeserializeObject(Of JObject)(JsonConvert.SerializeObject(cur))
.........
cb.Text = txt("type")
..........
Next
End Sub
Then I tried it in this line...
fillTabwithCB(jsonObj.cgFinishing.a3colorfn, 7, 7, 5)
It generates following error:
Value of type '1-dimensional array of
CG_FileManagement.A3colorfn' cannot be converted to
'Newtonsoft.Json.Linq.JArray'.
I'm trying to set a property of an object which is part of a class object array, for excel in VBA.
The code looks like this:
Dim myClass(5) as class1
Dim i as integer
For i = 0 to 5
set myClass(i) = New class
myClass(i).myProperty = "SomeValue"
Next i
Class code is simply:
Private pmyProperty as string
Public Property Let myProperty(s as string)
pmyProperty = s
End Property
Public Property Get myProperty() as string
myProperty = pmyProperty
End Property
However when I run this, I get a compile error "expected: list separator." This hits on the myClass(i).myProperty = "SomeValue" line.
How do I set the value of a property of an class object that is part of an array?
Any help would be great!
So the actual code is as follows...
Module code:
Public Sub main_sb_BillingApp()
Dim intCountComplete As Integer
Dim intLastRow As Integer
Dim Line() As clsLine
Dim i As Integer, x As Integer
intCountComplete = WorksheetFunction.CountIf(Sheets(WS_NAME).Columns(COL_W_COMPLETE), "Yes")
intLastRow = Sheets(WS_NAME).Cells(LAST_ROW, COL_W_COMPLETE).End(xlUp).Row - 1
ReDim Line(intCountComplete - 1)
For i = ROW_W_HEADER + 1 To intLastRow
If Sheets(WS_NAME).Cells(i, COL_W_COMPLETE) = "Yes" Then
Set Line(x) = New clsLine
Line(x).Row = i
x = x + 1
End If
Next i
End Sub
Class code:
Private pDate As Date
Private pUJN As String
Private pDesc As String
Private pCharge As Currency
Private pCost As Currency
Private pMargin As Double
Private pComplete As Boolean
Private pRow As Integer
Public Property Let Row(i As Integer)
pRow = i
Update
End Property
Public Property Get Row() As Integer
Row = pRow
End Property
Private Sub Update()
With Sheets(WS_NAME)
pDate = .Cells(pRow, COL_W_DATE)
pUJN = .Cells(pRow, COL_W_UJN)
pDesc = .Cells(pRow, COL_W_DESC)
pCharge = .Cells(pRow, COL_W_CHARGE)
pCost = .Cells(pRow, COL_W_COST)
pMargin = .Cells(pRow, COL_W_MARGIN)
If .Cells(pRow, COL_W_COMPLETE) = "Yes" Then
pComplete = True
Else
pComplete = False
End If
End With
End Sub
Line is a VBA reserved keyword, so you're confusing the compiler. Change the name of your object array and it works just fine:
Dim lineArray() As clsLine
'...
Set lineArray(x) = New clsLine
lineArray(x).Row = i
I have been scouring for an answer to simply pass and return a string array to a class module in vba. Below is my example code. I keep getting the error "Can't assign to array" on the line
Orgs.pIDOrgList = ID
Any thoughts?
Class Code:
'Class COrgList
Private m_vpIDOrgList() As Variant
'Public pGROrgList() As String
Function getOrgList(Comp As String) As String()
If Comp = "Gram Stain" Then
getOrgList = m_pGROrgList
ElseIf Comp = "Identification" Then
getOrgList = m_pIDOrgList
Else
MsgBox "Incorrect Comp Name"
End If
End Function
Public Property Get pIDOrgList() As Variant()
pIDOrgList = m_vpIDOrgList()
End Property
Public Property Let pIDOrgList(vpIDOrgList() As Variant)
m_vpIDOrgList = vpIDOrgList
End Property
Module Test Code:
Sub test()
Dim Orgs As COrgList
Set Orgs = New COrgList
Dim ID(2) As String
Dim GR(2) As String
ID(0) = "0"
ID(1) = "2"
ID(2) = "1"
Debug.Print ID(0)
Orgs.pIDOrgList = ID
Debug.Print Orgs.getOrgList("Identifciation")(1)
End Sub
Thank you!
You cant assign one array to another array, but you can assign one array to a simple variant.(http://msdn.microsoft.com/en-us/library/office/gg264711(v=office.14).aspx or http://www.cpearson.com/excel/passingandreturningarrays.htm)
so it should be:
'Class COrgList
Private m_vpIDOrgList As Variant
'Public pGROrgList() As String
Function getOrgList(Comp As String) As String()
If Comp = "Gram Stain" Then
'getOrgList = m_pGROrgList
ElseIf Comp = "Identification" Then
getOrgList = m_vpIDOrgList
Else
MsgBox "Incorrect Comp Name"
End If
End Function
Public Property Get pIDOrgList() As Variant
pIDOrgList = m_vpIDOrgList
End Property
Public Property Let pIDOrgList(vpIDOrgList As Variant)
m_vpIDOrgList = vpIDOrgList
End Property
also indentification is spelled wrong in Debug.Print Orgs.getOrgList("Identifciation")(1)