I have a VBA class:
Option Explicit
Public Re As Double 'Real
Public Im As Double 'Imaginary
Public Function CZ_Sqt(Z As Complex, Exp As Integer) As Variant
Dim Table() As Complex
Dim i As Integer
If Exp > 0 Then
ReDim Preserve Table(0 To Exp - 1)
Set Table(UBound(Table)) = New Complex
Else: Exit Function
End If
For i = 0 To UBound(Table)
Table(i).Re = 1
Table(i).Im = 1
Next i
set CZ_Sqt = Table
End Function
In module:
Sub asd()
Dim K As Complex
Dim A As Variant
Set K = New Complex
K.Re = 1
K.Im = 3
Set A = K.CZ_Sqt(Z, 5)
end sub
How "set" all variable "Table" in on step ?
In solution which is in example is set only element Table(4) but other elements are omited.
How to return this variable "Table" to the function name "CZ_Sqt" ?
This what I proposed doesn't work.
How pass variable "CZ_Sqt" which consider Array Complex type to the variable "A"?
You are using the same class as an object and object collection.
I would separate the functionalities into 2 Classes:
Complex
ComplexCollection - Contains a collection of complex class
EDIT: There is no duplicate check in ComplexCollection.Add and exists check in ComplexCollection.Retrieve.
Complex
Option Explicit
Public Re As Double
Public Im As Double
ComplexCollection
Option Explicit
Dim oCol As Collection
Public Function Create(pRe As Double, pIm As Double) As Complex
Dim oResult As Complex
Set oResult = New Complex
oResult.Re = pRe
oResult.Im = pIm
Set Create = oResult
End Function
Public Sub Add(pComplex As Complex, pKey As String)
oCol.Add pComplex, pKey
End Sub
Public Function Retrieve(pKey As String) As Complex
Set Retrieve = oCol(pKey)
End Function
Private Sub Class_Initialize()
Set oCol = New Collection
End Sub
Private Sub Class_Terminate()
Set oCol = Nothing
End Sub
Test.bas
Public Sub TestCollection()
Dim oCL As ComplexCollection
Dim oC As Complex
Set oCL = New ComplexCollection
Set oC = oCL.Create(1, 2)
Debug.Print oC.Im, oC.Re
oCL.Add oC, "1"
Set oC = Nothing
Set oC = oCL.Retrieve("1")
Debug.Print oC.Im, oC.Re
End Sub
Related
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.
my VBA-code is making trouble. I made a Class module called "clsColl" with the Properties. When i declare a variable as "clsColl" everything working fine, but when i declare an array as "clsColl" i get an error
"Object variable or With block variable not set", if i use this array in another sub, which i called in the first sub.
I made a short example with just the code in it which making trouble.
First my class module "clsColl"
Option Explicit
Public name As String
Public weight as single
Now the code which is working
Sub workingA()
Dim persona As New clsColl
Call workingB(persona)
End Sub
Sub workingB(persona As cls Coll)
persona.name = "phil"
persona.weight = 100
End Sub
Now the code which is not working
Sub failingA()
Dim persona() As New clsColl
ReDim persona(1 to 5)
Call failingB(persona)
End Sub
Sub failingB(persona() As cls Coll)
persona(1).name = "phil"
persona(1).weight = 100
End Sub
I get an error, just by changing my code from using a variable to using an array.
Now i get an error Object variable or With block variable not set" with the second code, but i don't know why. I want to know why using an array as an object is making trouble like this, while using a normal variable is working fine.
Your code line
Dim persona As New clsColl
is a combination of
Dim persona As clsColl
If persona Is Nothing Then Set persona = New clsColl
and it is bad practice using that combining syntax at all, at least in my opionion.
Now for the array this cannot work anymore as each array item must be Set to be an clsColl object first:
Sub notMorefailingA()
Dim persona() As clsColl
Dim i As Integer
ReDim persona(1 To 5)
For i = 1 To 5
Set persona(i) = New clsColl
Next
Call notMorefailingB(persona)
End Sub
Sub notMorefailingB(persona() As clsColl)
persona(1).name = "phil"
persona(1).weight = 100
End Sub
You have nothing in the array you need to populate the array with classes. Your Dim wont use the new keyword, you'll create new classes and add them into the array.
Sub test1()
Dim d As New clsDimension
Dim arrDimensions(5) As clsDimension
Set arrDimensions(0) = d
arrDimensions(0).Breadth = 100
arrDimensions(0).Depth = 200
End Sub
or in a similar approach to your post
A class for the array, like so, clsDimensionArray
Private arrDimensions() As clsDimension
Public Property Get ArrItems(x As Long) As clsDimension
Set ArrItems = arrDimensions(x)
End Property
Public Sub Create(lngSize As Long)
Dim l As Long
Dim d As clsDimension
ReDim arrDimensions(lngSize - 1)
For l = 0 To UBound(arrDimensions)
Set d = New clsDimension
Set arrDimensions(l) = d
Set d = Nothing
Next l
End Sub
and using like so
Sub test1()
Dim arrDimensions As New clsDimensionArray
arrDimensions.Create (100)
arrDimensions.ArrItems(90).Depth = 50
arrDimensions.ArrItems(90).Breadth = 100
End Sub
Keeps it nice and tidy :o)
I need some help learning how to handle rolling up data by hierarchy groupings in VBA (PivotTables and even tables are not going to be sufficient due to "end-user" limitations).
I have granular data that with three levels of groupings: Parent, Child, Grain. A Parent may have more than 1 Child; and each Child may have more than 1 Grain. I need to take the universe of granular data and perform some calculations and then produce reports a the Parent and Child levels. For illustrative purposes, below are hypothetical structure/layout of source and desired outputs.
I've explored using Dictionaries and Collections, but neither seems to have the ability to restrict to unique/distinct relationships. For example, Dictionary will restrict to distinct Keys but will allow repetitive string values.
For example: Plants: Edible_Or_Not / Classification / Type / item
Edible / Fruit / Apple / Granny Smith
Edible / Fruit / Apple / Red Delicious
Edible / Vegetable / Asparagus / Asparagus
Nonedible / Tree / Maple / Red
Summaries:
1) Edible composed of Fruit and Vegetable
2) Fruit composed of Apple
3) Apple composed of Granny Smith and Red Delicious.
Below are the layouts more accurately representing my data.
Source:|||||
Parent Category Label|Child Category Label|Granular Label|DataPoint1|DataPoint2…|DataPoint3
---|---|---|---|---|---|
String A|String z|string z.g1.g2.g3|5|FALSE|1/1/1960
String A|String y|String y.g1.g2.g3|0|TRUE|1/2/1970
String B|String w|String w.g1.g2.g3|0|TRUE|9/5/1980
String C|String m|String m.g1.g2.g3|100|TRUE|1/1/1949
String C|String m|String m.g1a.g2.g3|2|FALSE|2/14/2008
String C|String n|String n.g1.g2.g3|2|TRUE|1/1/1950
String C|String o|String o.g1.g2.g3|0|FALSE|1/1/1905
String C|String o|String o.g1a.g2a.g3|0|FALSE|3/1/1977
String C|String p|String p.g1.g2.g3|1|FALSE|4/1/2000
Rollup Need Example #1||||
Parent|Distinct Children Count|Child1|Child 2|….Child(# - last)
---|---|---|---|---|
String A|2|String Z|String Y||
String B|1|String w|||
String C|4|String m|String n|...String p|
Rollup Need Example #2||||
Parent|Calculated Value ->|Sum DataPoint1 if and only if: (DataPoint 2 = "T" OR (inclusive) DataPoint1 <>0 )AND where DataPoint3 >=1/1/1950
---|---|---|---|
A|5||||
B|0||||
C|5||||
I'm going to assume you have three ListObjects on three sheets in an Excel Workbook.
Sheet1 (tblParent)
Item
A
B
C
Sheet2 (tblChild)
Item Parent
z A
y A
w B
m C
n C
o C
p C
Sheet3 (tblGrain)
Grain Parent Data1 Data2 Data3
y.g1.g2.g3 y 0 TRUE 1/2/1970
w.g1.g2.g3 w 0 TRUE 9/5/1980
m.g1.g2.g3 m 100 TRUE 1/1/1949
n.g1.g2.g3 n 2 TRUE 1/1/1950
I would create six class modules named CParent, CParents, CChild, CChildren, CGrain, CGrains.
CParents
Private mcolParents As Collection
Private Sub Class_Initialize()
Set mcolParents = New Collection
End Sub
Private Sub Class_Terminate()
Set mcolParents = Nothing
End Sub
Public Property Get NewEnum() As IUnknown
Set NewEnum = mcolParents.[_NewEnum]
End Property
Public Sub Add(clsParent As CParent)
If clsParent.ParentID = 0 Then
clsParent.ParentID = Me.Count + 1
End If
mcolParents.Add clsParent, CStr(clsParent.ParentID)
End Sub
Public Property Get Parent(vItem As Variant) As CParent
Set Parent = mcolParents.Item(vItem)
End Property
Public Property Get Count() As Long
Count = mcolParents.Count
End Property
Public Sub FillFromRange(ByRef rParents As Range, ByRef rChildren As Range, ByRef rGrains As Range)
Dim vaParents As Variant
Dim i As Long
Dim clsParent As CParent
vaParents = rParents.Value
For i = LBound(vaParents, 1) To UBound(vaParents, 1)
Set clsParent = New CParent
With clsParent
.Name_ = vaParents(i, 1)
End With
Me.Add clsParent
clsParent.Children.FillFromRange rChildren, clsParent.Name_, rGrains
Next i
End Sub
CParent
Private mlParentID As Long
Private msName_ As String
Private mclsChildren As CChildren
Public Property Set Children(ByVal clsChildren As CChildren): Set mclsChildren = clsChildren: End Property
Public Property Get Children() As CChildren: Set Children = mclsChildren: End Property
Public Property Let ParentID(ByVal lParentID As Long): mlParentID = lParentID: End Property
Public Property Get ParentID() As Long: ParentID = mlParentID: End Property
Public Property Let Name_(ByVal sName_ As String): msName_ = sName_: End Property
Public Property Get Name_() As String: Name_ = msName_: End Property
Private Sub Class_Initialize()
Set mclsChildren = New CChildren
End Sub
Private Sub Class_Terminate()
Set mclsChildren = Nothing
End Sub
CChildren
Private mcolChildren As Collection
Private Sub Class_Initialize()
Set mcolChildren = New Collection
End Sub
Private Sub Class_Terminate()
Set mcolChildren = Nothing
End Sub
Public Property Get NewEnum() As IUnknown
Set NewEnum = mcolChildren.[_NewEnum]
End Property
Public Sub Add(clsChild As CChild)
If clsChild.ChildID = 0 Then
clsChild.ChildID = Me.Count + 1
End If
mcolChildren.Add clsChild, CStr(clsChild.ChildID)
End Sub
Public Property Get Child(vItem As Variant) As CChild
Set Child = mcolChildren.Item(vItem)
End Property
Public Property Get Count() As Long
Count = mcolChildren.Count
End Property
Public Sub FillFromRange(ByRef rRng As Range, ByVal sParentName As String, ByRef rGrains As Range)
Dim vaValues As Variant
Dim i As Long
Dim clsChild As CChild
vaValues = rRng.Value
For i = LBound(vaValues, 1) To UBound(vaValues, 1)
If vaValues(i, 2) = sParentName Then
Set clsChild = New CChild
With clsChild
.Name_ = vaValues(i, 1)
End With
Me.Add clsChild
clsChild.Grains.FillFromRange rGrains, clsChild.Name_
End If
Next i
End Sub
CChild
Private mlChildID As Long
Private msName_ As String
Private mclsGrains As CGrains
Public Property Set Grains(ByVal clsGrains As CGrains): Set mclsGrains = clsGrains: End Property
Public Property Get Grains() As CGrains: Set Grains = mclsGrains: End Property
Public Property Let ChildID(ByVal lChildID As Long): mlChildID = lChildID: End Property
Public Property Get ChildID() As Long: ChildID = mlChildID: End Property
Public Property Let Name_(ByVal sName_ As String): msName_ = sName_: End Property
Public Property Get Name_() As String: Name_ = msName_: End Property
Private Sub Class_Initialize()
Set mclsGrains = New CGrains
End Sub
Private Sub Class_Terminate()
Set mclsGrains = Nothing
End Sub
CGrains
Private mcolGrains As Collection
Private Sub Class_Initialize()
Set mcolGrains = New Collection
End Sub
Private Sub Class_Terminate()
Set mcolGrains = Nothing
End Sub
Public Property Get NewEnum() As IUnknown
Set NewEnum = mcolGrains.[_NewEnum]
End Property
Public Sub Add(clsGrain As CGrain)
If clsGrain.GrainID = 0 Then
clsGrain.GrainID = Me.Count + 1
End If
mcolGrains.Add clsGrain, CStr(clsGrain.GrainID)
End Sub
Public Property Get Grain(vItem As Variant) As CGrain
Set Grain = mcolGrains.Item(vItem)
End Property
Public Property Get Count() As Long
Count = mcolGrains.Count
End Property
Public Sub FillFromRange(ByRef rRng As Range, ByVal sChildName As String)
Dim vaValues As Variant
Dim i As Long
Dim clsGrain As CGrain
vaValues = rRng.Value
For i = LBound(vaValues, 1) To UBound(vaValues, 1)
If vaValues(i, 2) = sChildName Then
Set clsGrain = New CGrain
With clsGrain
.Data1 = vaValues(i, 3)
.Data2 = vaValues(i, 4)
.Data3 = vaValues(i, 5)
End With
Me.Add clsGrain
End If
Next i
End Sub
CGrain
Private mlGrainID As Long
Private mlData1 As Long
Private mbData2 As Boolean
Private mdtData3 As Date
Public Property Let GrainID(ByVal lGrainID As Long): mlGrainID = lGrainID: End Property
Public Property Get GrainID() As Long: GrainID = mlGrainID: End Property
Public Property Let Data1(ByVal lData1 As Long): mlData1 = lData1: End Property
Public Property Get Data1() As Long: Data1 = mlData1: End Property
Public Property Let Data2(ByVal bData2 As Boolean): mbData2 = bData2: End Property
Public Property Get Data2() As Boolean: Data2 = mbData2: End Property
Public Property Let Data3(ByVal dtData3 As Date): mdtData3 = dtData3: End Property
Public Property Get Data3() As Date: Data3 = mdtData3: End Property
All this has done so far is to create three objects, establish relationships between them, and provide a way to fill them with data from an Excel range.
The relationships are established in the single object classes (not the plural ones). The CParent class has a property that holds a CChildren collection class. All of the children for that parent are stored in that class. The CChildren class holds a bunch of CChild objects. Each CChild object has a property CGrains that holds all the grains for that child. This is a lot of setup, but the payoff is coming.
Next, in a standard module, I want to create the procedure that fills the classes.
Public gclsParents As CParents
Public Sub Initialize()
Set gclsParents = New CParents
gclsParents.FillFromRange Sheet1.ListObjects(1).DataBodyRange, Sheet2.ListObjects(1).DataBodyRange, Sheet3.ListObjects(1).DataBodyRange
End Sub
I create a Public variable for the top collection class so it doesn't go out of scope. In Intialize, I instantiate the top collection class variable and call the FillFromRange method. I pass it my three Excel tables and the code fills in the all the classes.
Now lets say you wanted to create a procedure that listed all parents, a count of their children, and a list of their children.
Public Sub ListChildren()
Dim sh As Worksheet
Dim vaWrite As Variant
If gclsParents Is Nothing Then Initialize
Set sh = ThisWorkbook.Worksheets.Add
vaWrite = gclsParents.ChildListToRange
sh.Range("A1").Resize(UBound(vaWrite, 1), UBound(vaWrite, 2)).Value = vaWrite
End Sub
My CParents instance (held in gclsParents) returns an array that is dumped to a new sheet. The output looks like
A 2 z,y
B 1 w
C 4 m,n,o,p
Now you have to create the ChildListToRange method. Add this to the CParents class
Public Property Get ChildListToRange() As Variant
Dim aReturn() As Variant
Dim clsParent As CParent
Dim lCnt As Long
ReDim aReturn(1 To Me.Count, 1 To 3)
For Each clsParent In Me
lCnt = lCnt + 1
aReturn(lCnt, 1) = clsParent.Name_
aReturn(lCnt, 2) = clsParent.Children.Count
aReturn(lCnt, 3) = clsParent.ChildListDelimited(",")
Next clsParent
ChildListToRange = aReturn
End Property
The first two columns in the array are already defined, but we need to create a ChildListDelimited property in the CParent class. Add this to CParent
Public Property Get ChildListDelimited(ByVal sDelim As String) As String
Dim clsChild As CChild
Dim aReturn() As String
Dim lCnt As Long
ReDim aReturn(1 To Me.Children.Count)
For Each clsChild In Me.Children
lCnt = lCnt + 1
aReturn(lCnt) = clsChild.Name_
Next clsChild
ChildListDelimited = Join(aReturn, sDelim)
End Property
You supply a delimiter, this property returns a string of all the children separated by that delimiter.
And that's it. Your first report is done. Next, you want to create a report that sums up Data1 with certain criteria. Create this procedure in a standard module
Public Sub SummarizeValues()
Dim sh As Worksheet
Dim vaWrite As Variant
Dim clsToSum As CParents
If gclsParents Is Nothing Then Initialize
Set sh = ThisWorkbook.Worksheets.Add
Set clsToSum = gclsParents.FilterByData2(True).FilterByData3(DateSerial(1950, 1, 1), ">=")
vaWrite = clsToSum.SummarizeGrainValues
sh.Range("A1").Resize(UBound(vaWrite, 1), UBound(vaWrite, 2)).Value = vaWrite
End Sub
That looks a lot like the first procedure except that the CParents property that returns the array (to be written to a worksheet) is different. Also, we do some filtering. In the first procedure, we wanted every parent. Now we only want parents that meet certain criteria. For that, create a couple of FilterBy properties. In CParents add
Public Property Get FilterByData2(ByVal lData As Long) As CParents
Dim clsParent As CParent
Dim clsNewParent As CParent
Dim clsChild As CChild
Dim clsReturn As CParents
Set clsReturn = New CParents
For Each clsParent In Me
Set clsNewParent = New CParent
clsNewParent.Name_ = clsParent.Name_
Set clsNewParent.Children = clsParent.Children.FilterByData2(lData)
If clsNewParent.Children.Count > 0 Then
clsReturn.Add clsNewParent
End If
Next clsParent
Set FilterByData2 = clsReturn
End Property
This is a common filtering property. It takes a big CParents instance (gclsParents in this case) and returns a smaller one. If it finds children that meet the criteria, it adds the parent to the return class. Otherwise it doesn't. But you'll need to pass that criteria down to the children. Add this to the CChildren class
Public Property Get FilterByData2(ByVal lData As Long) As CChildren
Dim clsChild As CChild
Dim clsNewChild As CChild
Dim clsGrain As CGrain
Dim clsReturn As CChildren
Set clsReturn = New CChildren
For Each clsChild In Me
Set clsNewChild = New CChild
clsNewChild.Name_ = clsChild.Name_
Set clsNewChild.Grains = clsChild.Grains.FilterByData2(lData)
If clsNewChild.Grains.Count > 0 Then
clsReturn.Add clsNewChild
End If
Next clsChild
Set FilterByData2 = clsReturn
End Property
And add this to the CGrains class
Public Property Get FilterByData2(ByVal lData As Long) As CGrains
Dim clsGrain As CGrain
Dim clsReturn As CGrains
Set clsReturn = New CGrains
For Each clsGrain In Me
If clsGrain.Data2 = lData Then
clsReturn.Add clsGrain
End If
Next clsGrain
Set FilterByData2 = clsReturn
End Property
All that returns a CParents instance with the only the parents that eventually have a grain with true in Data2.
From that already smaller CParents instance, we tack on another filter. Add this to CParents
Public Property Get FilterByData3(ByVal dtData As Date, ByVal sComp As String) As CParents
Dim clsParent As CParent
Dim clsNewParent As CParent
Dim clsChild As CChild
Dim clsReturn As CParents
Set clsReturn = New CParents
For Each clsParent In Me
Set clsNewParent = New CParent
clsNewParent.Name_ = clsParent.Name_
Set clsNewParent.Children = clsParent.Children.FilterByData3(dtData, sComp)
If clsNewParent.Children.Count > 0 Then
clsReturn.Add clsNewParent
End If
Next clsParent
Set FilterByData3 = clsReturn
End Property
Because this filter uses an inequality, it gets a little more complicated as we'll see in a minute. For now, add this to CChildren
Public Property Get FilterByData3(ByVal dtData As Date, ByVal sComp As String) As CChildren
Dim clsChild As CChild
Dim clsNewChild As CChild
Dim clsGrain As CGrain
Dim clsReturn As CChildren
Set clsReturn = New CChildren
For Each clsChild In Me
Set clsNewChild = New CChild
clsNewChild.Name_ = clsChild.Name_
Set clsNewChild.Grains = clsChild.Grains.FilterByData3(dtData, sComp)
If clsNewChild.Grains.Count > 0 Then
clsReturn.Add clsNewChild
End If
Next clsChild
Set FilterByData3 = clsReturn
End Property
And add this to CGrains
Public Property Get FilterByData3(ByVal dtData As Date, ByVal sComp As String) As CGrains
Dim clsGrain As CGrain
Dim clsReturn As CGrains
Dim bAdd As Boolean
Set clsReturn = New CGrains
For Each clsGrain In Me
Select Case sComp
Case ">="
bAdd = clsGrain.Data3 >= dtData
Case ">"
bAdd = clsGrain.Data3 > dtData
Case "<"
bAdd = clsGrain.Data3 < dtData
Case "<="
bAdd = clsGrain.Data3 <= dtData
Case Else
bAdd = clsGrain.Data3 = dtData
End Select
If bAdd Then
clsReturn.Add clsGrain
End If
Next clsGrain
Set FilterByData3 = clsReturn
End Property
You can see in CGrains that I have to use a Select Case to figure out what inequality you want. But other that wrinkle, it does the same thing as the first filter.
Now you have a variable clsToSum that is a CParents instance that only contains parents you want. You've already done the filtering, now all you have to do it sum stuff up. Add this to CParents
Public Property Get SummarizeGrainValues() As Variant
Dim clsParent As CParent
Dim aReturn() As Variant
Dim lCnt As Long
ReDim aReturn(1 To Me.Count, 1 To 2)
For Each clsParent In Me
lCnt = lCnt + 1
aReturn(lCnt, 1) = clsParent.Name_
aReturn(lCnt, 2) = clsParent.SumData1
Next clsParent
SummarizeGrainValues = aReturn
End Property
Now you have to add SumData1 to CParent
Public Property Get SumData1() As Long
Dim lReturn As Long
Dim clsChild As CChild
Dim clsGrain As CGrain
For Each clsChild In Me.Children
For Each clsGrain In clsChild.Grains
lReturn = lReturn + clsGrain.Data1
Next clsGrain
Next clsChild
SumData1 = lReturn
End Property
That loops through all the grains in all the children and adds them up. The output looks like
A 0
B 0
C 2
Now that the infrastructure is done, you can create any manner of report you want. You simply have to set up whatever filters you need and any aggregation properties you want to report.
I probably should have said this at the top, but if you put these three tables in a proper relational database, you can accomplish all this with two fairly short SQL statements.
If you want to see it all together in a workbook, download this http://dailydoseofexcel.com/excel/ClassParentChildGrains.zip
Custom classes would allow you to create a hierarchy, the example class below is to get you started.
A parent object can place child objects within the container collection and then perform rollup calculations aggregating all objects within the collection.
Assuming you place child objects within the collection you could place grain objects within their container also and create a hierarchy as suits.
Private pContainer As New Collection
Private pTitle As String
Private pValueToSum As Double
Public Property Get Container() As Collection
Set Container = pContainer
End Property
Public Property Let Container(value As Collection)
Set pContainer = value
End Property
Public Property Get GetTotals() As Double
Dim dbl As Double
Dim var As Variant
For Each var In Me.Container
dbl = dbl + var.ValueToSum
Next var
GetTotals = dbl
End Property
My custom object:
clsCAN:
Public ntc_id As String
Public grp_id As String
Public sat_name As String
Public freq_min As Long
Public freq_max As Long
Public ntc_type As String
I want to sort, in ascending order, by freq_max
Wrap VBA-Collection in a class and add your own Sort method. Here simple example with bubble sort. Bubble sort is easy to write but can perform well only with small amount of unsorted data, so if you have a lot of items in unsorted collection this might be really slow! HTH.
clsCANs class module
Option Explicit
Private list As Collection
Private Sub Class_Initialize()
Set list = New Collection
End Sub
Public Property Get Count() As Long
Count = list.Count
End Property
Public Sub Add(ByVal newItem As clsCAN)
On Error GoTo ErrAdd
list.Add newItem
ErrAdd:
Exit Sub
Err.Raise Err.Number, "clsCANs::Add", Err.Description
End Sub
Public Property Get Item(ByVal index As Integer) As clsCAN
On Error GoTo ErrItem
Set Item = list.Item(index)
Exit Property
ErrItem:
Err.Raise Err.Number, "clsCANs::Item", Err.Description
End Property
Public Sub Sort()
Dim swapOccured As Boolean
Dim i As Integer
Dim temp As clsCAN
Do
swapOccured = False
For i = 1 To list.Count - 1
If list.Item(i).freq_max > list.Item(i + 1).freq_max Then
' swap to achieve ascending order
Set temp = list.Item(i)
list.Remove i
list.Add temp, , After:=i
swapOccured = True
End If
Next i
' sorting has to continue while some swap was performed
Loop While swapOccured
End Sub
standard module
Option Explicit
Sub test()
Dim itm As clsCAN
Dim col As clsCANs
Set col = New clsCANs
Set itm = New clsCAN
itm.freq_max = 3
itm.sat_name = "sat_3"
col.Add itm
Set itm = New clsCAN
itm.freq_max = 7
itm.sat_name = "sat_7"
col.Add itm
Set itm = New clsCAN
itm.freq_max = 4
itm.sat_name = "sat_4"
col.Add itm
' etc for next items
col.Sort
Dim i As Integer
For i = 1 To col.Count
Debug.Print col.Item(i).sat_name
Next i
End Sub
Note: Collection wrapper is from here.