Geek Answers Handbook

VBA phrases when trying to execute a generated routine

I know that I should not do this, but I must.

I am trying to manipulate multidimensional arrays in VBA, in this particular case I need to add a row to a multidimensional array, and all but the last dimension have separate elements, such as Arr(1 To 1, 1 To 1, 1 To 3)

Since VBA does not allow access to elements of an array of arbitrary rank, I write sub at runtime:

Public Sub AddItemToReducedArr(ByRef Arr() As String, Dimensions As Byte, _
    Item As String
)
Dim VBComp As VBIDE.VBComponent
Dim i As Integer
Dim ArrElementS As String
Dim ArrElementR As String
    Set VBComp = ThisWorkbook.VBProject.VBComponents("modCustomCode")
    With VBComp.CodeModule
        .DeleteLines 1, .CountOfLines
        .InsertLines 1, _
            "Public Sub AddItemToReducedArrCode(ByRef Arr() As String, " & _
            "Dimensions As Byte, Item As String)"
        ArrElementS = _
            "Arr(" & Replace(String((Dimensions - 1), "*"), "*", "1, ") & _
            "*(Arr, " & Dimensions & "))"
        .InsertLines 2, "Debug.Print ""Enters Sub"""
        .InsertLines 3, "If LBound(Arr, " & Dimensions & ") = UBound(Arr, " & _
            Dimensions & ") And " & Replace(ArrElementS, "*", "UBound") & _
            " = """" Then"
        .InsertLines 4, Replace(ArrElementS, "*", "UBound") & " = Item"
        .InsertLines 5, "Else"
        ArrElementR = _
            "Arr(" & Replace(String((Dimensions - 1), "*"), "*", "1 To 1, ") & _
            "LBound(Arr, " & Dimensions & ") To UBound(Arr, " & Dimensions & ") + 1)"
        .InsertLines 6, "Redim Preserve " & ArrElementR
        .InsertLines 7, Replace(ArrElementS, "*", "UBound") & " = Item"
        .InsertLines 8, "End If"
        .InsertLines 9, "End Sub"
        Debug.Print "creates sub"
        'I also tried adding Sleep, many DoEvents here and saving, none worked
        AddItemToReducedArrCode Arr, Dimensions, Item
        Debug.Print "calls proper"
    End With
Set VBComp = Nothing
ResetCode
End Sub

ResetCode The routine simply clears the code inside the created element and is not specified for simplicity.

At this point, VBA does not allow you to step through the code, rarely runs as intended, and basically does not execute the created sub and sometimes chrashes.

, VBA ? , , ( ), , ?

, modCustomCode :

Public Sub testASDF()
Dim Arr() As String
    ReDim Arr(1 To 1, 1 To 2)
    Arr(1, 1) = "a"
    Arr(1, 2) = "b"
    AddItemToReducedArr Arr, 2, "c"
    Debug.Print UBound(Arr, 2)
    Debug.Print Arr(1, UBound(Arr, 2))
End Sub
+4
2

. :

  Dim vdaA As Variant

  ReDim vdaA(1 To 2)
  vdaA(1) = Array(1, 2, 3, 4)
  vdaA(2) = Array(5, 6, 7, 8, 9, 10)
  Debug.Print vdaA(1)(0) & " " & vdaA(1)(1) & " " & vdaA(1)(2) & " " & vdaA(1)(3)
  Debug.Print vdaA(2)(0) & " " & vdaA(2)(1) & " " & vdaA(2)(2) & " " & _
              vdaA(2)(3) & " " & vdaA(2)(4) & " " & vdaA(2)(5)

:

1 2 3 4 
5 6 7 8 9 10

vdaA , Redim 1D-. , ReDim vdaA(1)(0 to 3). vdaA (1) vdaA (2) , . vdaA (1) Redim .

vdaA Jagged. "Jagged array", , .

, , , , , . vdaA(1) , . vdaA(1)(1) . , . .

, , , . , , . , .

. . "" , .

, Param Arrays. , VBA Param Arrays , . , .

:

Sub MySub(ByRef A As Long, ByVal B As String, ParamArray Z() As Variant)

A B . C, D, E .., . - , , A B , . :

Call MySub(27, "A", 1, "X")
Call MySub(54, "B", 1, "X", 2, "Y")
Call MySub(54, "B", 1, "X", 2, "Y", 3, "Z")

. , VarType , .

:

Sub VdaInit(ByRef Vda As Variant, ParamArray Bounds() As Variant)

:

Call VdaInit(vdaA, 1, 2)
Call VdaInit(vdaA, 1, 2, -1, 4)
Call VdaInit(VdaB, 1, 2, -1, 4, 10, 15)
Call VdaInit(vdaA, 1, 2, -1, 4, 10, 15, 5, 6)
Call VdaInit(VdaB, 1, 2, -1, 4, 10, 15, 5, 6, 0, 4)

:

ReDim vdaA(1 to 2)
ReDim vdaA(1 to 2, -1 to 4)
ReDim vdaA(1 to 2, -1 to 4, 10 to 15)
ReDim vdaA(1 to 2, -1 to 4, 10 to 15, 5 to 6)
ReDim vdaA(1 to 2, -1 to 4, 10 to 15, 5 to 6, 0 to 4)

:

Call VdaStoreValue(vdaA, DateSerial(2014, 1, 7), 2, 4, 15, 5)
Result = VdaGetValue(VdaB, 2, 4, 15, 5, 4)

:

Vda(2, 4, 15, 5) = DateSerial(2014, 1, 7)
Result = VdaB(2, 4, 15, 5, 4)

, - .

, VdaGetValue :

  DimMax = NumDim(Vda)
  Select Case DimMax
    Case 1
      VdaGetValue = Vda(Indices(0))
    Case 2
      VdaGetValue = Vda(Indices(0), Indices(1))
    Case 3
      VdaGetValue = Vda(Indices(0), Indices(1), Indices(2))
    Case 4
      VdaGetValue = Vda(Indices(0), Indices(1), Indices(2), Indices(3))
    Case 5
      VdaGetValue = Vda(Indices(0), Indices(1), Indices(2), Indices(3), Indices(4))
  End Select

, 10 15 , .

. , , .

Option Explicit
Sub Test()

  Dim vdaA As Variant
  Dim VdaB As Variant

'  ReDim vdaA(1 To 2)
'  vdaA(1) = Array(1, 2, 3, 4)
'  vdaA(2) = Array(5, 6, 7, 8, 9, 10)
'  Debug.Print vdaA(1)(0) & " " & vdaA(1)(1) & " " & vdaA(1)(2) & " " & vdaA(1)(3)
'  Debug.Print vdaA(2)(0) & " " & vdaA(2)(1) & " " & vdaA(2)(2) & " " & _
'              vdaA(2)(3) & " " & vdaA(2)(4) & " " & vdaA(2)(5)

  Call VdaInit(vdaA, 1, 2)
  Debug.Print "VdaA" & VdaBoundList(vdaA)
  Call VdaInit(vdaA, 1, 2, -1, 4)
  Debug.Print "VdaA" & VdaBoundList(vdaA)
  Call VdaInit(VdaB, 1, 2, -1, 4, 10, 15)
  Debug.Print "VdaB" & VdaBoundList(VdaB)
  Call VdaInit(vdaA, 1, 2, -1, 4, 10, 15, 5, 6)
  Debug.Print "VdaA" & VdaBoundList(vdaA)
  Call VdaInit(VdaB, 1, 2, -1, 4, 10, 15, 5, 6, 0, 4)
  Debug.Print "VdaB" & VdaBoundList(VdaB)

  Call VdaStoreValue(vdaA, "A", 1, -1, 10, 5)
  Call VdaStoreValue(vdaA, 27, 1, -1, 10, 6)
  Call VdaStoreValue(vdaA, 5.3, 1, -1, 11, 5)
  Call VdaStoreValue(vdaA, DateSerial(2014, 1, 7), 2, 4, 15, 5)

  Call VdaStoreValue(VdaB, True, 1, -1, 10, 5, 0)
  Call VdaStoreValue(VdaB, "B", 1, -1, 10, 5, 1)
  Call VdaStoreValue(VdaB, False, 1, -1, 10, 5, 2)
  Call VdaStoreValue(VdaB, 1234, 2, 4, 15, 5, 4)

  Debug.Print "VdaA(1, -1, 10, 5) = " & VdaGetValue(vdaA, 1, -1, 10, 5)
  Debug.Print "VdaA(1, -1, 10, 6) = " & VdaGetValue(vdaA, 1, -1, 10, 6)
  Debug.Print "VdaA(1, -1, 11, 5) = " & VdaGetValue(vdaA, 1, -1, 11, 5)
  Debug.Print "VdaA(2, 4, 15, 5) = " & VdaGetValue(vdaA, 2, 4, 15, 5)

  Debug.Print "VdaB(1, -1, 10, 5,0) = " & VdaGetValue(VdaB, 1, -1, 10, 5, 0)
  Debug.Print "VdaB(1, -1, 10, 5,1) = " & VdaGetValue(VdaB, 1, -1, 10, 5, 1)
  Debug.Print "VdaB(1, -1, 10, 5,2) = " & VdaGetValue(VdaB, 1, -1, 10, 5, 2)
  Debug.Print "VdaB(2, 4, 15, 5, 4) = " & VdaGetValue(VdaB, 2, 4, 15, 5, 4)

End Sub
Sub VdaInit(ByRef Vda As Variant, ParamArray Bounds() As Variant)

  ' Vda:     A variant which is to be converted to a multi-dimensional array.
  ' Bounds:  One or more pairs of bounds for the dimensions.  The number of pairs
  '          defines the number of dimensions.  For each pair, the first value is
  '          the lower bound and the second is the upper bound.

  ' This routine creates dimension 1 and calls VdaInitSub to create
  ' further dimensions

  ' I use Debug.Assert because I am testing for errors that only the programmer
  ' should see.
  Debug.Assert UBound(Bounds) >= 1       ' Need at least one pair of bounds
  Debug.Assert UBound(Bounds) Mod 2 = 1  ' Need even number of bounds
  ' I do not check that the bounds are valid integers

  Select Case UBound(Bounds)
    Case 1
      ReDim Vda(Bounds(0) To Bounds(1))
    Case 3
      ReDim Vda(Bounds(0) To Bounds(1), Bounds(2) To Bounds(3))
    Case 5
      ReDim Vda(Bounds(0) To Bounds(1), Bounds(2) To Bounds(3), _
                Bounds(4) To Bounds(5))
    Case 7
      ReDim Vda(Bounds(0) To Bounds(1), Bounds(2) To Bounds(3), _
                Bounds(4) To Bounds(5), Bounds(6) To Bounds(7))
    Case 9
      ReDim Vda(Bounds(0) To Bounds(1), Bounds(2) To Bounds(3), _
                Bounds(4) To Bounds(5), Bounds(6) To Bounds(7), _
                Bounds(8) To Bounds(9))
  End Select

End Sub
Function VdaBoundList(ByVal Vda As Variant) As String

  ' Vda: A variant which has been converted to a multi-dimensional array.

  ' Returns a string of the format: "(L1 to U1, L2 to U3 ... )
  ' which gives the dounds of each dimension

  Dim DimCrnt As Long
  Dim DimMax As Long

  DimMax = NumDim(Vda)

  VdaBoundList = "("
  For DimCrnt = 1 To DimMax
    VdaBoundList = VdaBoundList & LBound(Vda, DimCrnt) & " to " & UBound(Vda, DimCrnt)
    If DimCrnt < DimMax Then
      VdaBoundList = VdaBoundList & ", "
    End If
  Next
  VdaBoundList = VdaBoundList & ")"

End Function
Function VdaGetValue(ByRef Vda As Variant, ParamArray Indices() As Variant) As Variant

  ' Vda:     A variant which has been converted to a multi-dimensional array.
  ' Indices  The parameters are the indices of the entry within Vda from which the value is got.
  '          The number of indices must match the number of dimensions of Vda.

  ' Example: Result = VdaGetValue(XYZ, 1, 2, 3)
  '          is equivalent to Result = XYZ(1, 2, 3)
  '          providing XYZ has three dimensions and 1, 2 and 3 are within the
  '          bounds of their dimension

  Dim DimCrnt As Long
  Dim DimMax As Long

  DimMax = NumDim(Vda)

  Debug.Assert UBound(Indices) = DimMax - 1    ' Wrong number of parameters
  'For DimCrnt = 1 To DimMax
  '  Debug.Assert IsNumeric(indices(DimCrnt - 1)) ' Index must be numeric
  '  ' Index not within bounds
  '  Debug.Assert LBound(indices, DimCrnt - 1) <= indices(DimCrnt - 1) And _
  '               UBound(indices, DimCrnt - 1) >= indices(DimCrnt - 1)
  'Next

  Select Case DimMax
    Case 1
      VdaGetValue = Vda(Indices(0))
    Case 2
      VdaGetValue = Vda(Indices(0), Indices(1))
    Case 3
      VdaGetValue = Vda(Indices(0), Indices(1), Indices(2))
    Case 4
      VdaGetValue = Vda(Indices(0), Indices(1), Indices(2), Indices(3))
    Case 5
      VdaGetValue = Vda(Indices(0), Indices(1), Indices(2), Indices(3), Indices(4))
  End Select

End Function
Sub VdaStoreValue(ByRef Vda As Variant, ParamArray ValAndIndices() As Variant)

  ' Vda:           A variant which has been converted to a multi-dimensional array.
  ' ValAndIndices  The first parameter is the value to be stored.  Since this is a
  '                Variant array it can be of any type.  The second and subsequent
  '                parameters are the indices of the entry within Vda into which
  '                the value is to be stored.  The number of indices must match the
  '                number of dimensions of Vda.

  ' Example: VdaStoreValue(XYZ, "Example", 1, 2, 3)
  '          is equivalent to XYZ(1, 2, 3) = "Example"
  '          providing XYZ has three dimensions and 1, 2 and 3 are within the
  '          bounds of their dimension

  Dim DimCrnt As Long
  Dim DimMax As Long

  DimMax = NumDim(Vda)

  Debug.Assert UBound(ValAndIndices) = DimMax    ' Wrong number of parameters
  ' I do not check the indices are numeric and within the appropriate bounds

  Select Case DimMax
    Case 1
      Vda(ValAndIndices(1)) = ValAndIndices(0)
    Case 2
      Vda(ValAndIndices(1), ValAndIndices(2)) = ValAndIndices(0)
    Case 3
      Vda(ValAndIndices(1), ValAndIndices(2), ValAndIndices(3)) = ValAndIndices(0)
    Case 4
      Vda(ValAndIndices(1), ValAndIndices(2), ValAndIndices(3), _
          ValAndIndices(4)) = ValAndIndices(0)
    Case 5
      Vda(ValAndIndices(1), ValAndIndices(2), ValAndIndices(3), _
          ValAndIndices(4), ValAndIndices(5)) = ValAndIndices(0)
  End Select

End Sub

Public Function NumDim(ParamArray TestArray() As Variant) As Integer

  ' Returns the number of dimensions of TestArray.

  ' If there is an official way of determining the number of dimensions, I cannot find it.

  ' This routine tests for dimension 1, 2, 3 and so on until it get a failure.
  ' By trapping that failure it can determine the last test that did not fail.

  ' Coded June 2010. Documentation added July 2010.

  ' *  TestArray() is a ParamArray because it allows the passing of arrays of any type.
  ' *  The array to be tested is not TestArray but TestArray(LBound(TestArray)).
  ' *  The routine does not validate that TestArray(LBound(TestArray)) is an array.  If
  '    it is not an array, the routine return 0.
  ' *  The routine does not check for more than one parameter.  If the call was
  '    NumDim(MyArray1, MyArray2), it would ignore MyArray2.

  Dim TestDim                   As Integer
  Dim TestResult                As Integer

  On Error GoTo Finish

  TestDim = 1
  Do While True
    TestResult = LBound(TestArray(LBound(TestArray)), TestDim)
    TestDim = TestDim + 1
  Loop

Finish:

  NumDim = TestDim - 1

End Function

, "" .

, Main, SubA SubB SubA, SubB Param Paramus "Param" . , SubA , Main to SubB.

Main SubA:

Call SubA("A", 1, #1/10/2014#, 2.45)

SubA, Param :

Param(0) = "A"
Param(1) = 1
Param(2) = #1/10/2014#, 2.45
Param(3) = 2.45

SubA SubB:

Call SubB(Param)

SubB Param . :

Param(0) = Array("A", 1, #1/10/2014#, 2.45)

. SubB SubA, SubB Param. , SubB Main, . , SubC SubD , .

Param , :

Sub DeNestParamArray(RetnValue() As Variant, ParamArray Nested() As Variant)

  ' Coded Nov 2010

  ' Each time a ParamArray is passed to a sub-routine, it is nested in a one
  ' element Variant array.  This routine finds the bottom level of the nesting and
  ' sets RetnValue to the values in the original parameter array so that other routine
  ' need not be concerned with this complication.

  Dim NestedCrnt                As Variant
  Dim Inx                       As Integer

  NestedCrnt = Nested
  ' Find bottom level of nesting
  Do While True
    If VarType(NestedCrnt) < vbArray Then
      ' Have found a non-array element so must have reached the bottom level
      Debug.Assert False   ' Should have exited loop at previous level
      Exit Do
    End If
    If NumDim(NestedCrnt) = 1 Then
      If LBound(NestedCrnt) = UBound(NestedCrnt) Then
        ' This is a one element array
        If VarType(NestedCrnt(LBound(NestedCrnt))) < vbArray Then
          ' But it does not contain an array so the user only specified
          ' one value; a literal or a non-array variable
          ' This is a valid exit from this loop
            Exit Do
        End If
        NestedCrnt = NestedCrnt(LBound(NestedCrnt))
      Else
        ' This is a one-dimensional, non-nested array
        ' This is the usual exit from this loop
        Exit Do
      End If
    Else
      Debug.Assert False   ' This is an array but not a one-dimensional array
      Exit Do
    End If
  Loop

  ' Have found bottom level array.  Save contents in Return array.
  ReDim RetnValue(LBound(NestedCrnt) To UBound(NestedCrnt))
  For Inx = LBound(NestedCrnt) To UBound(NestedCrnt)
    If VarType(NestedCrnt(Inx)) = vbObject Then
      Set RetnValue(Inx) = NestedCrnt(Inx)
    Else
      RetnValue(Inx) = NestedCrnt(Inx)
    End If
  Next

End Sub
+1

, . , :

, , , - () , .

sub ;

.InsertLines 1, "Public Function AddItemToReducedArrCode(ByRef Arr() As String, " & _
    Dimensions As Byte, Item As String) As String()"
...
.InsertLines 8, "AddItemToReducedArrCode = Arr"

, :

Arr = Application.Run("AddItemToReducedArrCode", Arr, Dimensions, Item)

, , , , , - . VBA!

+1

More articles:


All Articles