我知道我不应该这样做，但我必须这样做。
我正在尝试在 VBA 中操作多维数组，在这种特定情况下，我必须向多维数组添加一个字符串，除了最后一个维度之外的所有维度都具有单个元素，例如 Arr(1 To 1, 1 To 1, 1 To 3)
由于 VBA 不允许访问任意等级数组的元素，我在运行时编写了一个 sub:
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将其转换为一维数组。如果你输入 ReDim vdaA(1)(0 to 3)，你会得到一个语法错误。 .但是，您可以将 vdaA(1) 和 vdaA(2) 转换为不同大小的数组，如我所示。或者，您可以将 vdaA(1) 作为 Variant 和 ReDim 传递给子例程。它在那里。我已将 vdaA 转换为锯齿状数组。如果您搜索“锯齿状阵列”，您可以获得对它们的更全面的描述，但我已经为您提供了足够的介绍来回答这个问题。
据我了解，您不需要不同的行来拥有不同的列数，但我相信您可以看到可用的灵 active 。您可以通过
vdaA(1)向下到将其转换为数组的子例程。 vdaA(1)(1)然后可以传递下来进行转换。使用递归，您可以声明在运行时所需的任意多维的数组。其他递归例程可以定位特定条目并设置或获取值。许多年前，我确实让这项技术发挥了作用，尽管它伤害了我的大脑。我不再拥有该代码，除非没有其他东西可以满足要求，否则我不会推荐它。但是，如果需要，它可以工作。
下面的代码使用了一种更简单的技术。它只处理常规数组，最多处理五个维度。 “五”是任意的，如果需要，代码可以很容易地调整到更大的限制。
在展示代码之前，我想讨论一下参数数组。过去我很惊讶有多少经验丰富的 VBA 程序员不知道参数数组或它们给你的灵 active 。对不起，如果我侮辱你的知识。
一个可能的声明是:
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”的参数数组作为它们唯一的参数。进一步假设 SubA 将它从 Main 接收到的 Param Array 传递给 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 并且可以从他们的任何 parent 那里调用它们，它仍然会变得更加困惑。
我使用以下例程将嵌套到任何深度的参数数组和参数数组转换为一致的格式:
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
关于arrays - 尝试执行生成的子时 VBA 崩溃，我们在Stack Overflow上找到一个类似的问题： https://stackoverflow.com/questions/20971161/