Cloning Custom Object from Array - Excel Crashes

[nickninevah]

Hello everyone. I have some custom defined VBA classes and no idea why they keep causing Excel to crash. My classes define objects. I use instances of those objects in dynamic arrays. I can't use collections because I need to edit the objects in the arrays and swap out the entries in the arrays. As part of the class definition, I have a method to clone the object. It duplicates all internal variables into a new object, completely independent. This method works perfectly fine, except when my source object and target object are entries in an array.

Here is the skeleton version of my code:

Class definition:
CHROMOSOME

Public Sub Clone(ByRef cloneIn As Chromosome)
'Create new object
Set cloneIn = New Chromosome


'Copy over the variables
....
End Sub

Example of usage:

Dim popOut() As Chromosome
Dim pChromo() as as Chromosome
Dim i As Long                               'Counting variable
Dim j As Long                               'counting variable

Redim popOut(1 to j)
Redim popOut(1 to j)

for i = 1 to j
  pChromo(i).Clone popOut(i)
next

And I have error handling code included. But every time, excel just crashes. No warning. no error message, nothing. All my functions and subroutines use ByRef arguments for passing my arrays. Any ideas?

 

[mikerickson]

I would have made Clone a function rather than a sub, so it could return the new Chromosome object.

Also, with arrays, you have to instancize each element.
(Also, you dimensioned popOut twice and pChromo not at all)

For i = 1 to j
    Set pChromo(i) = New Chromosome
    pChromo(i).Clone popOut(i)
Next I

 

[nickninevah]

My mistake. I tried to simplify the example and typed the code wrong. Here is some more information about my project and the corrected code, showing more detail about how I actually use it.

General overview of my code structure and execution sequence

Evolver (VBA custom object)
1.) Generate Chromosomes (VBA custom object)
2.) Pass to Evaluator (VBA custom object)
2.1) Evaluator manipulates objects
3.) Pass to Selector (VBA custom object)
3.1) Selector manipulates Chromosome objects and resorts Chromosome array
3.2) Selector copies the resorted array back to the Evolver master object (this is where I use the Clone sub)
4.) Pass to Mutator (VBA custom object)
4.1) Mutator manipulates Chromosome objects and resorts Chromosome array
4.2) Mutator copies the resorted array back to the Evolve master object (using Clone sub again)
5.) Repeat steps 1 through 4 several thousand times.


Corrected code:

CLASS Selector

Private pChromo() as Chromosome

Public Sub GetSelection(byRef popOut as Chromosome)

   Dim pChromo() as Chromosome
   Dim i As Long             'Counting variable
   Dim j As Long             'counting variable

   'pChromo is already dimensioned and instancized by the time this routine gets called.

   'invoke another subroutine to sort pChromo.  This is why
   'I need to keep with arrays.  I do a lot of sorting operations.

   for i = 1 to j
      'Copy the sorted array back to the main array in my Evolver object.
      'My Evolver object holds the master array that passes to all the sub objects.
      pChromo(i).Clone popOut(i)
   next
End Sub

I hope that updated code helps explain my problem a little better.

You suggested defining the routine as a function instead of a sub. Any advantage? Is there some reason that the function returning the object would work when the by returning ByRef will not work? I'm honestly lost for any reason why my code doesn't work. So I'm happy for any experience. Even ghosts in the machine.

 

[mikerickson]

Where does the array pChromo get dimensioned?
Is there an Initialize event for the Selector class?

 

[nickninevah]

It gets dimensioned in a seperate Sub called setChromosome. Funny thing. I was trying to keep these as skeleton examples to avoid the complexity of the code, but I think I create more problems than I solved. Here are the full sub definitions that I have in my Selector class.

Public Sub setChromsome(ByRef chromoIn() As Chromosome)
'======================================================================================================================
'Author:        Nicholas Barczak
'Description:   Inputs the chromosomes to the selector.
'Inputs:        The collection of chromosomes to perform selection on.
'Revision History
'----------------------------------------------------------------------------------------------------------------------
'Rev    Date            Author                  Description
'----------------------------------------------------------------------------------------------------------------------
'0.10   2016-07-31      Nicholas Barczak        Initially created
'1.00   2016-09-11      Nicholas Barczak        Debugged and updated to Rev 1.0
'
'======================================================================================================================


'Variable Declaration
'======================================================================================================================
Dim i As Long                       'Counting variable
Dim tempChromo As Chromosome        'Temporary chromosome to get value transferred to alpha
Dim iAlpha As Long                  'Records the index of the best chromosome.
Dim alphaFit As Double              'Records the best fitness


'Main Program
'======================================================================================================================
'Turn on error handler
On Error GoTo lblErrsetChromosome


'Resize array
ReDim pChromo(LBound(chromoIn) To UBound(chromoIn))


For i = LBound(chromoIn) To UBound(chromoIn)
    chromoIn(i).Clone pChromo(i)
Next


'Reset the selection center metric
pSelCenter = 0


'Check if there is no alpha yet.
alphaFit = -1000000#
If pAlpha Is Nothing Then
    For i = 1 To UBound(chromoIn)
        If chromoIn(i).Fitness > alphaFit Then
            iAlpha = i
            alphaFit = chromoIn(i).Fitness
        End If
    Next
    
    pChromo(iAlpha).Clone pAlpha
End If
'======================================================================================================================
Exit Sub


lblErrsetChromosome:


'Error Handler
'======================================================================================================================
Call ErrorHandler("setChromosome")
'======================================================================================================================
End Sub

Public Sub getSelection(ByRef popOut() As Chromosome)
'======================================================================================================================
'Author:        Nicholas Barczak
'Description:   This performs the random selection of individuals and returns the next generation of the population.
'Input:         PopOut:         Reference to the array that you want the new population to end in.
'
'Revision History
'----------------------------------------------------------------------------------------------------------------------
'Rev    Date            Author                  Description
'----------------------------------------------------------------------------------------------------------------------
'0.10   2016-08-02      Nicholas Barczak        Initially created
'1.00   2016-09-11      Nicholas Barczak        Debugged and updated to Rev 1.0
'1.20   2018-12-21      Nicholas Barczak        Fixed problem where selector may never pick chromosomes.
'
'======================================================================================================================


'Variable Declaration
'======================================================================================================================
Dim i As Long                               'Counting variable
Dim j As Long                               'counting variable
Dim Marker As Double                        'The random number generated and used to select the chromosomes.


'Main Program
'======================================================================================================================
'Turn on error handler
On Error GoTo lblErrgetSelection


'Reset the population variable
Erase popOut
ReDim popOut(1 To UBound(pChromo))


'Calcuate the probabilities for all the chromosomes
calcProbability


i = LBound(pChromo)
Do While i <= UBound(pChromo)
    'Generate random number
    Marker = Random
    
    'Check to see which chromosome is within the marker window
    For j = 1 To UBound(pChromo)
        If (Marker >= pChromo(j).LowerProb) And (Marker < pChromo(j).UpperProb) Then
            pChromo(j).Clone popOut(i)
            i = i + 1
            Exit For
        End If
    Next
Loop


'sort the chromosomes in ascending order of fitness
QuickSort popOut, LBound(popOut), UBound(popOut)
'======================================================================================================================
Exit Sub


lblErrgetSelection:
'Error handler
'======================================================================================================================
Call ErrorHandler("getSelection")
'======================================================================================================================
End Sub

And just to be thorough, here are the internal variables, constructor and terminator definitions.

'Private variable declaration
'======================================================================================================================
Option Explicit
Private pAlpha As Chromosome                        'The global best chromosome
Private Ps As Double                                'The selective pressure variable
Private iGen As Long                                'The current generation number
Private nGen As Long                                'The total number of generations
Private pChromo() As Chromosome                     'The array of chromosomes
Private pSelCenter As Double                        'The center of selection for the Chromosomes.
'======================================================================================================================

Private Sub Class_Initialize()
'======================================================================================================================
'Class constructor
'Author:        Nicholas Barczak
'Description:   The class constructor
'Revision History
'----------------------------------------------------------------------------------------------------------------------
'Rev    Date            Author                  Description
'----------------------------------------------------------------------------------------------------------------------
'0.10   2016-07-31      Nicholas Barczak        Initially created
'1.00   2016-09-11      Nicholas Barczak        Debugged and updated to Rev 1.0
'
'======================================================================================================================


'Initialize the internal variables
'Create a default value for selective pressure.
Ps = 1#
'======================================================================================================================
End Sub

Private Sub Class_Terminate()
'======================================================================================================================
'Class Destructor
'Author:        Nicholas Barczak
'Description:   The class destructor.  Excecuted when the class is terminated.
'Revision History
'----------------------------------------------------------------------------------------------------------------------
'Rev    Date            Author                  Description
'----------------------------------------------------------------------------------------------------------------------
'0.10   2016-07-31      Nicholas Barczak        Initially created
'1.00   2016-09-11      Nicholas Barczak        Debugged and updated to Rev 1.0
'
'======================================================================================================================


Set pAlpha = Nothing
Erase pChromo


'Turn off error handler
On Error GoTo 0


'======================================================================================================================
End Sub

In my main code, I call these two subs right after each other:

Private Selector As Selector                    'The selector to perform selection of chromosomes for each generation
Set Selector = New Selector

Selector.setChromsome Population

At this point, I wonder if my dynamic arrays may be dropping an element at some point. I'm going to throw in some more code to check for allocated elements and see if that catches anything.

 

[nickninevah]

I tried redefining my clone sub as a function. And now at least it throws an error message before Excel crashes. Error 91. Object variable or Block variable not set. And I know the error originated from within my getSelection Sub. It sure looks like somehow my program is erasing a Chromosome object in the array. But I no idea how. The error is intermittent. It doesn't help that this is a genetic evolution program and based on several random processes stacked together. Still, this is the first clue I have. Now I have a hint of what to start looking for.

 

[nickninevah]

Nope. Just a typo from when I implemented the new function. Back to square one.

 

[nickninevah]

Problem solved. I added a new sub to my Selector Class.

Private Sub Clone(ByRef cloneIn As Chromosome, ByRef cloneOut As Chromosome)
'Variable Declaration
'======================================================================================================================
Dim i As Long                               'Counting variable
Dim j As Long                               'Counting variable
Dim k As Long                               'Counting variable


'Main Program
'======================================================================================================================
'Turn on error handler
On Error GoTo lblErrClone


'Create new object
k = 1
Set cloneOut = New Chromosome


'Copy over the genes
k = 2
For i = 1 To cloneIn.Genes.Count
    cloneOut.Genes.Add cloneIn.Genes.Item(i)
Next


'Copy over the baseline genes
k = 3
For i = 1 To cloneIn.BaselineGenes.Count
    cloneOut.BaselineGenes.Add cloneIn.BaselineGenes.Item(i)
Next


'Copy over the constraints
k = 4
For i = 1 To cloneIn.Constraints.Count
    cloneOut.Constraints.Add cloneIn.Constraints.Item(i)
Next


'Copy over the fitness
k = 5
cloneOut.Fitness = cloneIn.GetFitness(False)


'Copy over the lower probability and upper probability
k = 6
cloneOut.LowerProb = cloneIn.LowerProb
cloneOut.UpperProb = cloneIn.UpperProb


'Copy the straight probability
k = 7
cloneOut.Probability = cloneIn.Probability


'Copy the lower and upper limits for new class
k = 8
If Not cloneIn.Limits Is Nothing Then
    cloneOut.Limits = cloneIn.Limits
End If
'======================================================================================================================
Exit Sub
lblErrClone:
'Error Handler
'======================================================================================================================
Call ErrorHandler("Clone::" & k)
'======================================================================================================================
End Sub

It does the same thing as the sub that was part of my Chromosome class, but now it was part of my Selector class and acting external to my Chromosome objects. After much debugging, I found the problem seemed to be when I initially brought my Chromosome objects into the Selector class. For some reason, they didn't always copy over correctly. Using this new external sub, they always copied over. I also solved the problem with my Excel crashing at a bug. I wasn't properly clearing my arrays in several of my classes.

So I added the following code to the Terminate Sub of any class that an array of Chromosome Objects.

'Delete the population
'Population is an array of Chromosome objects
Dim i As Long           'Counting variable
For i = 1 To Ubound(Population)
    Set Population(i) = Nothing
Next


'Erase the array
Erase Population

That cleaned up the code. It now behaves nicely. All I can say, don't ignore the class terminations. I learned my lesson.