VBAで渡された（バリアント）変数の次元数を返す方法

Question

誰もがVBAで渡された（バリアント）変数の次元数を返す方法を知っていますか？

Answer 1

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を見ると、彼らは基本的に同じことをしました。

Answer 2

エラーを飲み込むことなく次元数を返すには：

#If VBA7 Then
  Private Type Pointer: Value As LongPtr: End Type
  Private Declare PtrSafe Sub RtlMoveMemory Lib "kernel32" (ByRef dest As Any, ByRef src As Any, ByVal Size As LongPtr)
#Else
  Private Type Pointer: Value As Long: End Type
  Private Declare Sub RtlMoveMemory Lib "kernel32.dll" (ByRef dest As Any, ByRef src As Any, ByVal Size As Long)
#End If

Private Type TtagVARIANT
    vt As Integer
    r1 As Integer
    r2 As Integer
    r3 As Integer
    sa As Pointer
End Type


Public Function GetDims(source As Variant) As Integer
    Dim va As TtagVARIANT
    RtlMoveMemory va, source, LenB(va)                                            ' read tagVARIANT              '
    If va.vt And &H2000 Then Else Exit Function                                   ' exit if not an array         '
    If va.vt And &H4000 Then RtlMoveMemory va.sa, ByVal va.sa.Value, LenB(va.sa)  ' read by reference            '
    If va.sa.Value Then RtlMoveMemory GetDims, ByVal va.sa.Value, 2               ' read cDims from tagSAFEARRAY '
End Function

使用法：

Sub Examples()

    Dim list1
    Debug.Print GetDims(list1)    ' >> 0  '

    list1 = Array(1, 2, 3, 4)
    Debug.Print GetDims(list1)    ' >> 1  '

    Dim list2()
    Debug.Print GetDims(list2)    ' >> 0  '

    ReDim list2(2)
    Debug.Print GetDims(list2)    ' >> 1  '

    ReDim list2(2, 2)
    Debug.Print GetDims(list2)    ' >> 2  '

    Dim list3(0 To 0, 0 To 0, 0 To 0)
    Debug.Print GetDims(list3)    ' >> 3  '

End Sub

Answer 3

配列の場合、MSにはエラーが発生するまでループスルーするNiceメソッドがあります。

「このルーチンは、各次元のLBoundをテストすることにより、Xarrayという名前の配列をテストします。For... Nextループを使用して、エラーが生成されるまで、最大60000までの可能な配列次元の数を繰り返します。ループが失敗したカウンターステップを取り、1を減算し（前のものがエラーのない最後のものだったため）、結果をメッセージボックスに表示します。.. "

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

Answer 4

@cularisと@Issunは、尋ねられた正確な質問に対して完全に適切な答えを持っています。ただし、あなたの質問に質問します。未知の次元数の配列が本当にたくさんありますか？ Excelで作業している場合、これが発生する唯一の状況は、1次元配列または2次元配列（または非配列）のいずれかが渡される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 (i.e.
    ''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の優れたWebサイトへのリンクに注意してください。 http://www.cpearson.com/Excel/VBAArrays.htm

参照： VB6で配列が初期化されているかどうかを確認する方法 。文書化されていない動作が依存していることは個人的には好きではなく、私が書いているExcel VBAコードではパフォーマンスはそれほど重要ではありませんが、それでも興味深いものです。

Answer 5

MicrosoftはVARIANTとSAFEARRAYの構造を文書化しており、それらを使用してバイナリデータを解析してディメンションを取得できます。

通常のコードモジュールを作成します。私は「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

Answer 6

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

Answer 7

On Error Resume Nextを使用せずに、ほとんどのプログラマが嫌いであり、デバッグ中に「Break On All Errors」を使用してコードを停止できないことを意味すると推測します（ツール->オプション->一般->エラートラップ->すべてのエラーで中断）。

私にとっての1つの解決策は、On Error Resume Nextをコンパイル済みDLLに埋め込むことです。昔はVB6でした。今日はVB.NETを使用できますが、私はC＃を使用することを選択します。

Visual Studioが利用可能な場合、ここにいくつかのソースがあります。辞書を返し、Dicitionary.Countは次元数を返します。アイテムには、連結された文字列としてLBoundとUBoundも含まれます。私は常にその次元だけでなく、それらの次元の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

NOTE WELL：この回答は、Dim s(1)などを使用してコードで作成された配列だけでなく、Range.Valueを含むワークシートから引き出されたグリッドバリアントを処理します！他の答えはこれを行いません。