我知道我不应该这样做,但我必须这样做.

我正在尝试在VBA中操作多维数组,在这种特定情况下,我必须向多维数组添加一个字符串,除了最后一个维度之外的所有数据都具有单个元素,如Arr(1到1,1对1,1到3 )

由于VBA不允许访问任意级别数组的元素,因此我在运行时编写一个子类：

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子例程只清除创建的子代码中的代码,为简单起见,未列出.

在这个阶段,VBA不允许单步执行代码,很少按预期执行,并且大部分不执行创建的子程序,有时会崩溃.

除了将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

最佳答案 另一种方法是使用变体.考虑：

  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声明为Variant,然后使用Redim将其转换为1D数组.如果键入ReDim vdaA(1)(0到3),将出现语法错误.但是,您可以将vdaA(1)和vdaA(2)转换为不同大小的数组,如我所示.或者,您可以将vdaA(1)作为Variant传递给子程序,然后在那里重新调整它.

我已将vdaA转换为Jagged数组.如果您搜索“锯齿状阵列”,您可以获得更全面的描述,但我已经为您提供了足够的介绍,以达到此答案的目的.

据我了解,您不需要不同的行来拥有不同数量的列,但我相信您可以看到可用的灵活性.您可以将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等.我的最后一个参数是Param数组,这意味着我可以使用我需要的参数来跟踪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

编辑新部分,解释Param阵列的“问题”并提供可能的解决方案.

假设我有三个例程Main,SubA和SubB,SubA和SubB都将Param Arrays命名为“Param”作为它们唯一的参数.进一步假设SubA将从Main接收的Param数组传递给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)

我叫这个嵌套.如果只能通过SubA调用SubB,则可以对SubB进行编码以处理嵌套的Param数组.但是,如果SubB也可以调用SubB,它会有点乱.如果你有SubC和SubD与Param Arrays,它会得到消息,并且可以从他们的任何父母调用它们.

我使用以下例程将嵌套到任何深度的Param Arrays和Param Arrays转换为一致的格式：

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