如何返回在VBA中传递给它的（Variant）variables的维数
有谁知道如何返回在VBA中传递给它的（Variant）variables的维数？
Function getDimension(var As Variant) As Long On Error GoTo Err Dim i As Long Dim tmp As Long i = 0 Do While True i = i + 1 tmp = UBound(var, i) Loop Err: getDimension = i - 1 End Function 这是我能想出的唯一方法。 不漂亮…。
看着MSDN，他们基本上也是这样做的。
@cularis和@Issun对于确切的问题提供了完美的答案。 不过，我会质疑你的问题。 你真的有一堆数组未知的维数浮动吗？ 如果你在Excel中工作，唯一出现这种情况的应该是一个UDF，你可能会传递一个一维数组或者一个二维数组（或者一个非数组），但是没有别的。
你应该几乎从来没有一个期望任意东西的例程。 因此，你可能不应该有一个普遍的“寻找数组维数”例程。
所以，考虑到这一点，这里是我使用的例程：
Global Const ERR_VBA_NONE& = 0 Global Const ERR_VBA_SUBSCRIPT_OUT_OF_RANGE& = 9 'Tests an array to see if it extends to a given dimension Public Function arrHasDim(arr, dimNum As Long) As Boolean Debug.Assert IsArray(arr) Debug.Assert dimNum > 0 'Note that it is possible for a VBA array to have no dimensions (ie ''LBound' raises an error even on the first dimension). This happens 'with "unallocated" (borrowing Chip Pearson's terminology; see 'http://www.cpearson.com/excel/VBAArrays.htm) dynamic arrays - 'essentially arrays that have been declared with 'Dim arr()' but never 'sized with 'ReDim', or arrays that have been deallocated with 'Erase'. On Error Resume Next Dim lb As Long lb = LBound(arr, dimNum) 'No error (0) - array has given dimension 'Subscript out of range (9) - array doesn't have given dimension arrHasDim = (Err.Number = ERR_VBA_NONE) Debug.Assert (Err.Number = ERR_VBA_NONE Or Err.Number = ERR_VBA_SUBSCRIPT_OUT_OF_RANGE) On Error GoTo 0 End Function '"vect" = array of one and only one dimension Public Function isVect(arg) As Boolean If IsObject(arg) Then Exit Function End If If Not IsArray(arg) Then Exit Function End If If arrHasDim(arg, 1) Then isVect = Not arrHasDim(arg, 2) End If End Function '"mat" = array of two and only two dimensions Public Function isMat(arg) As Boolean If IsObject(arg) Then Exit Function End If If Not IsArray(arg) Then Exit Function End If If arrHasDim(arg, 2) Then isMat = Not arrHasDim(arg, 3) End If End Function
请注意链接到Chip Pearson的优秀网站： http : //www.cpearson.com/excel/VBAArrays.htm
另请参阅： 如何确定数组是否在VB6中初始化？ 。 我个人不喜欢它所依赖的无证行为，而性能在我写的Excel VBA代码中很less重要，但它仍然很有趣。
对于数组，MS有一个很好的方法，包括循环直到发生错误。
“这个例程通过testing每个维度的LBound来testing名为Xarray的数组，使用For … Next循环，循环遍历可能的数组维度的数量，直到产生错误为止，然后error handling程序采取循环失败的计数器步骤，减去一个（因为前一个是没有错误的最后一个），并将结果显示在消息框中。
http://support.microsoft.com/kb/152288
清理版本的代码（决定写作一个函数，而不是子）：
Function NumberOfDimensions(ByVal vArray As Variant) As Long Dim dimnum As Long On Error GoTo FinalDimension For dimnum = 1 To 60000 ErrorCheck = LBound(vArray, dimnum) Next FinalDimension: NumberOfDimensions = dimnum - 1 End Function
要返回没有吞咽错误的维数：
Private Declare PtrSafe Sub memcpy Lib "kernel32" Alias "RtlMoveMemory" ( _ ByRef dest As Any, ByVal src As LongPtr, ByVal size As LongPtr) Public Function GetDimensions(source As Variant) As Integer Dim vt As Long, ptr As LongPtr memcpy vt, VarPtr(source), 2 ' read the variant type (2 bytes) ' If (vt And &H2000) = 0 Then Exit Function ' return 0 if not an array ' memcpy ptr, VarPtr(source) + 8, Len(ptr) ' read the variant data at offset 8 ' If (vt And &H4000) Then memcpy ptr, ptr, Len(ptr) ' read by reference if the data is a reference ' If ptr Then memcpy GetDimensions, ptr, 2 ' read the number of dimensions at offset 0 (2 bytes) ' End Function
用法：
Sub Examples() Dim list1 Debug.Print GetDimensions(list1) ' >> 0 ' list1 = Array(1, 2, 3, 4) Debug.Print GetDimensions(list1) ' >> 1 ' Dim list2() Debug.Print GetDimensions(list2) ' >> 0 ' ReDim list2(2) Debug.Print GetDimensions(list2) ' >> 1 ' ReDim list2(2, 2) Debug.Print GetDimensions(list2) ' >> 2 ' End Sub
微软已经logging了VARIANT和SAFEARRAY的结构，并使用那些你可以parsing二进制数据来获得维度。
创build一个正常的代码模块。 我称之为“mdlDims”。 您可以通过调用简单函数GetDims并将其传递给一个数组来使用它。
Option Compare Database Option Explicit Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Integer) Private Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (var() As Any) As Long 'http://msdn.microsoft.com/en-us/library/windows/desktop/ms221482(v=vs.85).aspx Private Type SAFEARRAY cDims As Integer fFeatures As Integer cbElements As Long cLocks As Long pvData As Long End Type 'Variants are all 16 bytes, but they are split up differently based on the contained type 'VBA doesn't have the ability to Union, so a Type is limited to representing one layout 'http://msdn.microsoft.com/en-us/library/windows/desktop/ms221627(v=vs.85).aspx Private Type ARRAY_VARIANT vt As Integer wReserved1 As Integer wReserved2 As Integer wReserved3 As Integer lpSAFEARRAY As Long data(4) As Byte End Type 'http://msdn.microsoft.com/en-us/library/windows/desktop/ms221170(v=vs.85).aspx Private Enum VARENUM VT_EMPTY = &H0 VT_NULL VT_I2 VT_I4 VT_R4 VT_R8 VT_CY VT_DATE VT_BSTR VT_DISPATCH VT_ERROR VT_BOOL VT_VARIANT VT_UNKNOWN VT_DECIMAL VT_I1 = &H10 VT_UI1 VT_UI2 VT_I8 VT_UI8 VT_INT VT_VOID VT_HRESULT VT_PTR VT_SAFEARRAY VT_CARRAY VT_USERDEFINED VT_LPSTR VT_LPWSTR VT_RECORD = &H24 VT_INT_PTR VT_UINT_PTR VT_ARRAY = &H2000 VT_BYREF = &H4000 End Enum Public Function GetDims(VarSafeArray As Variant) As Integer Dim varArray As ARRAY_VARIANT Dim lpSAFEARRAY As Long Dim sArr As SAFEARRAY 'Inspect the Variant CopyMemory VarPtr(varArray.vt), VarPtr(VarSafeArray), 16& 'If the Variant is pointing to an array... If varArray.vt And (VARENUM.VT_ARRAY Or VARENUM.VT_BYREF) Then 'Get the pointer to the SAFEARRAY from the Variant CopyMemory VarPtr(lpSAFEARRAY), varArray.lpSAFEARRAY, 4& 'If the pointer is not Null If Not lpSAFEARRAY = 0 Then 'Read the array dimensions from the SAFEARRAY CopyMemory VarPtr(sArr), lpSAFEARRAY, LenB(sArr) 'and return them GetDims = sArr.cDims Else 'The array is uninitialized GetDims = 0 End If Else 'Not an array, you could choose to raise an error here GetDims = 0 End If End Function
我认为你的意思是不使用On Error Resume Next，大多数程序员不喜欢，也意味着在debugging过程中，你不能使用'Break On All Errors'来让代码停止死亡（Tools-> Options-> General-> Error陷印 – >打破所有错误）。
对我来说，一个解决scheme是将任何错误恢复下一步埋入一个编译的DLL，在过去，这将是VB6。 今天你可以使用VB.NET，但我select使用C＃。
如果Visual Studio可用，那么这里是一些源代码。 它将返回一个字典，Dicitionary.Count将返回维数。 这些项目还将包含LBound和UBound作为连接string。 我总是在查询一个数组，而不仅仅是它的维数，而且也是这些维数的LBound和UBound，所以我把它们放在一起，并在Scripting Dictionary中返回一大堆信息
这里是C＃源码，启动一个类库，调用它BuryVBAErrorsCS，设置ComVisible（true）为COM库添加一个引用“Microsoft Scripting Runtime”，注册为Interop。
using Microsoft.VisualBasic; using System; using System.Runtime.InteropServices; namespace BuryVBAErrorsCS { // Requires adding a reference to COM library Microsoft Scripting Runtime // In AssemblyInfo.cs set ComVisible(true); // In Build tab check 'Register for Interop' public interface IDimensionsAndBounds { Scripting.Dictionary DimsAndBounds(Object v); } [ClassInterface(ClassInterfaceType.None)] [ComDefaultInterface(typeof(IDimensionsAndBounds))] public class CDimensionsAndBounds : IDimensionsAndBounds { public Scripting.Dictionary DimsAndBounds(Object v) { Scripting.Dictionary dicDimsAndBounds; dicDimsAndBounds = new Scripting.Dictionary(); try { for (Int32 lDimensionLoop = 1; lDimensionLoop < 30; lDimensionLoop++) { long vLBound = Information.LBound((Array)v, lDimensionLoop); long vUBound = Information.UBound((Array)v, lDimensionLoop); string concat = (string)vLBound.ToString() + " " + (string)vUBound.ToString(); dicDimsAndBounds.Add(lDimensionLoop, concat); } } catch (Exception) { } return dicDimsAndBounds; } } }
对于Excel客户端VBA代码在这里是一些来源
Sub TestCDimensionsAndBounds() '* requires Tools->References->BuryVBAErrorsCS.tlb Dim rng As Excel.Range Set rng = ThisWorkbook.Worksheets.Item(1).Range("B4:c7") Dim v As Variant v = rng.Value2 Dim o As BuryVBAErrorsCS.CDimensionsAndBounds Set o = New BuryVBAErrorsCS.CDimensionsAndBounds Dim dic As Scripting.Dictionary Set dic = o.DimsAndBounds(v) Debug.Assert dic.Items()(0) = "1 4" Debug.Assert dic.Items()(1) = "1 2" Dim s(1 To 2, 2 To 3, 3 To 4, 4 To 5, 5 To 6) Set dic = o.DimsAndBounds(s) Debug.Assert dic.Items()(0) = "1 2" Debug.Assert dic.Items()(1) = "2 3" Debug.Assert dic.Items()(2) = "3 4" Debug.Assert dic.Items()(3) = "4 5" Debug.Assert dic.Items()(4) = "5 6" Stop End Sub
注意好 ：这个答案处理从Range.Value的工作表中拉出的网格变体以及使用Dim s（1）等代码创build的数组！ 一些其他的答案不这样做。
Function ArrayDimension(ByRef ArrayX As Variant) As Byte Dim i As Integer, a As String, arDim As Byte On Error Resume Next i = 0 Do a = CStr(ArrayX(0, i)) If Err.Number > 0 Then arDim = i On Error GoTo 0 Exit Do Else i = i + 1 End If Loop If arDim = 0 Then arDim = 1 ArrayDimension = arDim End Function
那么使用ubound（var）+ 1呢？ 这应该给你大部分variables的最后一个元素（除非它是一个自定义范围，但在这种情况下，你应该知道这个信息）。 常规variables的范围（例如，使用分割函数时）从0开始; ubound会为您提供variables的最后一项。 所以如果你有一个8个元素的variables，例如它将从0（lbound）到7（ubound），你可以知道添加ubound（var）+ 1的元素的数量。例如：
Public Sub PrintQntElements() Dim str As String Dim var As Variant Dim i As Integer str = "Element1!Element2!Element3!Element4!Element5!Element6!Element7!Element8" var = Split(str, "!") i = UBound(var) + 1 Debug.Print "First element: " & LBound(var) Debug.Print "Last element: " & UBound(var) Debug.Print "Quantity of elements: " & i End Sub
它将把这个输出打印到Inmediate窗口中：
第一个元素：0
最后一个元素：7
元素数量：8
此外，如果您不确定第一个元素（lbound）是否为0，则可以使用：
i = UBound（var） – LBound（var）+ 1
我发现了一个非常简单的方法来检查，可能载满了一堆编码错误，不正确的行话和不良build议的技术，但从来没有less说：
Dim i as Long Dim VarCount as Long Dim Var as Variant 'generate your variant here i = 0 VarCount = 0 recheck1: If IsEmpty(Var(i)) = True Then GoTo VarCalc i = i + 1 GoTo recheck1 VarCalc: VarCount= i - 1
注意：如果Var（0）不存在，VarCount显然会返回一个负数。 VarCount是Var（i）使用的最大参考编号，i是您拥有的变体数量。