Excelでの行列計算は便利なんだけど、セルが跨いでる値を配列として計算したい場合、飛んでるセルを束ねて整理する列を作ったりする必要がある。こんな中間セルを作るのは面倒なんで、複数のセルを結合して配列を作る関数が無いか探してみたんだけど無いみたいだった。(Microsoftは、VBAで配列は使わせたくない節がある。。。)

仕方が無いんでCreateVectorHっていう、sum関数みたいなノリで領域指定したら、引数をHorizontal配列にして返す関数を作った。Horizontal配列作る関数作ったら、Vertical配列で戻す関数もセットで欲しいんで、CreateVectorVって関数でCreateVectorHをラップして、返ってきた水平方向の配列を転置しようと考えた。サクッと出来ると思ったんだけど、結構手間取った。

ユーザー定義関数(UDF)の可変長引数関数を、可変長引数関数でラップして作ろうとした場合、ParamArrayで受けたものをそのまま別のParamArrayに渡したら、Variant型の階層配列になってしまった。
受けた側は可変長引数の1つの要素として取り扱うんだから、当然っちゃー当然。

取り合えず、Range型か判定して処理するかと思ったもので調べてみたところ、VarType関数やTypeName関数を使うと判定できるっぽいんでこの辺参考にしつつテストしてみた。

Sub VarTest()
  Dim i As Integer
  Dim d As Double
  Dim str As String
  Dim bool As Boolean
  Dim data As Date
  Dim obj As Object
  Dim v As Variant
  Dim vArr() As Variant
  Dim rng As Range
  Dim strArr() As String
  Dim iArr() As Integer
  MsgBox "Integer：" & VarType(i) & ", " & TypeName(i) & vbCrLf & _
         "Double：" & VarType(d) & ", " & TypeName(d) & vbCrLf & _
         "String：" & VarType(str) & ", " & TypeName(str) & vbCrLf & _
         "Boolean：" & VarType(bool) & ", " & TypeName(bool) & vbCrLf & _
         "Date：" & VarType(data) & ", " & TypeName(data) & vbCrLf & _
         "Object：" & VarType(obj) & ", " & TypeName(obj) & vbCrLf & _
         "Variant：" & VarType(v) & ", " & TypeName(v) & vbCrLf & _
         "Array Variant：" & VarType(vArr) & ", " & TypeName(vArr) & vbCrLf & _
         "Range：" & VarType(rng) & ", " & TypeName(rng) & vbCrLf & _
         "Array String：" & VarType(strArr) & ", " & TypeName(strArr) & vbCrLf & _
         "Array Integer：" & VarType(iArr) & ", " & TypeName(iArr)
End Sub

結果を見ると、細かい型は判定できないみたい。VarTypeだと、RangeはObject型として判定された。(戻り値9)

これでRangeとVariantの判定が出来るかと思ったんだけど、Variantは何も入れてないとEmptyが返るように、代入される値によって判定される型が変わるようだった。

また、Rangeみたいなclassは、代入先がint型かStringかなどの型式に応じて戻り値の型を変えることが多い。念のため、Excel Sheetから選択範囲がどの様に判定されるかテストしてみた。

試してみたのは下記のUDF。引数をAs Variantにしてるか、As Rangeにしてるかの違いだけ。

Function VarTypeTestVariant(Arr As Variant)
    VarTypeTestVariant = VarType(Arr)
End Function

Function VarTypeTestRange(Arr As Range)
    VarTypeTestRange = VarType(Arr)
End Function

黄色で塗りつぶした範囲のセルを上記関数に送ってみた。結果としては、VarTypeTestVariant(C3)という感じで送ると、単一セルの場合、空白セルは空、文字や数値はそれぞれIntなどの対応する型が返ってくるけど、VarTypeTestVariant(C6:D6)という感じで範囲選択した場合は、全てVariant型の配列という判定がされるみたい。

これだとParamArrayで受け取ったVariant型配列か、シートの選択範囲なのか判定できない。

仕方ないのでLBoundが走らなければ、Rangeという感じで型判定して処理することにした。

CreateVectorH, CreateVectorV

実装は下記の様な感じ。適当に再帰関数書いて実装しました。CreateVectorH使うと、EXCELのセルから配列作れるので、MMULTなどの行列計算が捗ります。

'https://memo-nikki.info/?p=1214
Function CountAllItem(ParamArray arr() As Variant)
    Dim i As Long
    Dim LB_Arr As Long, UB_Arr As Long
    LB_Arr = LBound(arr)
    UB_Arr = UBound(arr)
    
    Dim LB_Arr1st As Long, UB_Arr1st As Long
    Dim n_tmp As Long
    CountAllItem = 0
    If LB_Arr = UB_Arr Then    '可変引数で送られた要素が1個だけ
        If VarType(arr(0)) < vbArray Then    'この1個の要素が配列でなければ1を返す。
            CountAllItem = 1
            Exit Function
        Else    '可変引数で送られてきた要素が配列なら、
            On Error GoTo LabelMaybeRange
            LB_Arr1st = LBound(arr(0))
            UB_Arr1st = UBound(arr(0))
            For i = LB_Arr1st To UB_Arr1st
                n_tmp = CountAllItem(arr(0)(i))
                If n_tmp < 0 Then
                    GoTo LabelError
                End If
                CountAllItem = CountAllItem + n_tmp
            Next
        End If
    Else
        For i = LB_Arr To UB_Arr
            n_tmp = CountAllItem(arr(i))
            If n_tmp < 0 Then
                GoTo LabelError
            End If
            CountAllItem = CountAllItem + n_tmp
        Next
    End If
    Exit Function
LabelMaybeRange:
    On Error GoTo LabelError
    CountAllItem = arr(0).Count
    Exit Function
LabelError:
    Debug.Print "CountAllItemに送られた、データは配列でなく、Count要素も持っていない要素が含まれている。"
    CountAllItem = -1
End Function
Function CountAllItem_Help()
    CountAllItem_Help = "CountAllItem(ParamArray arr() As Variant, ...)" & vbCrLf _
    & "引数はsum関数と同じ感じで指定。階層配列を探索し、引数群が持っている要素数の合計を返す。" & vbCrLf _
    & "イレギュラーな要素が含まれていた場合、Errorで-1を返す。"
End Function

'https://memo-nikki.info/?p=1214
Function ArrayCopy(ByRef TgtArr() As Variant, ByVal StartPos As Integer, ByRef RefArr() As Variant)
    Const strErrorArrayCopy As String = "<Error,ArrayCopy>"
    Dim i As Long
    
    Dim LB_TgtArr As Long, UB_TgtArr As Long
    Dim LB_RefArr As Long, UB_RefArr As Long
    LB_TgtArr = LBound(TgtArr)
    UB_TgtArr = UBound(TgtArr)
    LB_RefArr = LBound(RefArr)
    UB_RefArr = UBound(RefArr)
    
    Dim tmp_Vec() As Variant, tmp As Variant
    Dim EndPos_TgtArr As Long
    EndPos_TgtArr = StartPos + UB_RefArr - LB_RefArr
    If EndPos_TgtArr > UB_TgtArr Then
        ReDim tmp_Vec(LB_TgtArr To EndPos_TgtArr)
    Else
        ReDim tmp_Vec(LB_TgtArr To UB_TgtArr)
    End If
    '前方
    For i = LB_TgtArr To StartPos - 1
        tmp_Vec(i) = TgtArr(i)
    Next
    'コピー部
    Dim diff As Long
    diff = LB_RefArr - StartPos
    For i = StartPos To EndPos_TgtArr
        tmp_Vec(i) = RefArr(i + diff)
    Next
    '後部
    For i = EndPos_TgtArr + 1 To UB_TgtArr
        tmp_Vec(i) = TgtArr(i)
    Next
    
    ArrayCopy = tmp_Vec
    Exit Function
LabelError:
    Debug.Print "ArrayCopyに送られた、データは配列でなく、Count要素も持っていない要素が含まれている。"
    ArrayCopy = strErrorArrayCopy
End Function
Function ArrayCopy_Help()
    ArrayCopy_Help = "ArrayCopy(ByRef TgtArr() As Variant, ByVal StartPos As Integer, ByRef RefArr() As Variant)" & vbCrLf _
    & "TgtArrに対し、StartPosを開始点として、RefArrをコピーした配列を返す。" & vbCrLf _
    & "戻す配列は、TgtArrとは別に作成されるので、送信元の配列は変化しない。" & vbCrLf _
    & "イレギュラーな要素が含まれていた場合、""<Error,ArrayCopy>""を返す。" & vbCrLf _
    & "本関数はEXCEL Sheet上からRangeを送っても使えない。sheetからならCreateVectorHでこと足りるはず。"
End Function

'https://memo-nikki.info/?p=1214
Function CreateVectorH(ParamArray arr() As Variant)
    Const strErrorVecH As String = "<Error,CreateVectorH>"
    Dim n_Vec As Long, n As Long, i As Long, j As Long
    Dim LB_Arr As Long, UB_Arr As Long
    LB_Arr = LBound(arr)
    UB_Arr = UBound(arr)
    
    Dim obj, tmp() As Variant
    Dim n_tmp As Long
    Dim tmp_Vec() As Variant
    n_Vec = CountAllItem(arr)
    If n_Vec < 0 Then
        GoTo LabelError
    End If
    ReDim tmp_Vec(n_Vec - 1)
    n = 0
    Dim LB_Arr1st As Long, UB_Arr1st As Long
    If LB_Arr = UB_Arr Then    '可変引数で送られた要素が1個だけ
        If VarType(arr(0)) < vbArray Then    'この1個の要素が配列でなければこの要素を返す。
            CreateVectorH = arr(0)
            Exit Function
        Else    '可変引数で送られてきた要素が配列なら、
            On Error GoTo LabelMaybeRange
            LB_Arr1st = LBound(arr(0))
            UB_Arr1st = UBound(arr(0))
            For i = LB_Arr1st To UB_Arr1st
                If VarType(arr(0)(i)) < vbArray Then    '配列でなければそのまま代入。
                    tmp_Vec(n) = arr(0)(i)
                    n = n + 1
                Else    '配列なら
                    tmp = CreateVectorH(arr(0)(i))  '整理された配列を取得
                    tmp_Vec = ArrayCopy(tmp_Vec, n, tmp)
                    n = n + 1 + UBound(tmp)
                End If
            Next
            GoTo LabelMaybeRangeEnd
LabelMaybeRange:
            On Error GoTo LabelError
            For Each obj In arr(0)
                If VarType(obj) < vbArray Then    '配列でなければそのまま代入。
                    tmp_Vec(n) = obj
                    n = n + 1
                Else    '配列なら
                    tmp = CreateVectorH(obj)  '整理された配列を取得
                    tmp_Vec = ArrayCopy(tmp_Vec, n, tmp)
                    n = n + 1 + UBound(tmp)
                End If
            Next
LabelMaybeRangeEnd:
        End If
    Else
        For i = LB_Arr To UB_Arr
            If VarType(arr(i)) < vbArray Then    '配列でなければそのまま代入。
                tmp_Vec(n) = arr(i)
                n = n + 1
            Else    '配列なら
                tmp = CreateVectorH(arr(i))  '整理された配列を取得
                tmp_Vec = ArrayCopy(tmp_Vec, n, tmp)
                n = n + 1 + UBound(tmp)
            End If
        Next
    End If
    
    CreateVectorH = tmp_Vec
    Exit Function
LabelError:
    Debug.Print "CreateVectorHに送られた、データは配列でなく、Count要素も持っていない要素が含まれている。"
    CreateVectorH = strErrorVecH
End Function
Function CreateVectorH_Help()
    CreateVectorH_Help = "CreateVectorH(ParamArray arr() As Variant, ...)" & vbCrLf _
    & "sum関数と同じ感じで指定した引数を、水平方向の配列にして返す。"
End Function

'https://memo-nikki.info/?p=1214
Function CreateVectorV(ParamArray ArrRngTgt() As Variant)
    CreateVectorV = WorksheetFunction.Transpose(CreateVectorH(ArrRngTgt))
End Function
Function CreateVectorV_Help()
    CreateVectorV_Help = "CreateVectorV(ParamArray arr() As Variant, ...)" & vbCrLf _
    & "sum関数と同じ感じで指定した引数を、垂直方向の配列にして返す。"
End Function

例えば、下図のB列ような感じで、簡単にN次関数が書けちゃいます。

意味合い的には、A2^{0,1,2}という感じの表現です。デフォルト機能だと、{0,1,2}みたいに乗数の配列を書くか、C列みたいに逐次乗数を選択する形になります。{0,1,2}のような配列の作成は定数のみで、セルの値から作成できません。また、逐次乗数を選択するのは、数増えると見にくいし、書くのも大変なのでやりたくありません。

CreateVectorHを使うとこれが簡単に実現できるので、めちゃくちゃ楽になりました。

これで行列計算がはかどります。

ふと思いましたが、CreateVectorH使うと、可変長引数、多次元配列、階層配列、Range、この辺ごちゃまぜでも、全ての要素を単純な1次元配列として返すので、構造を気にしない可変長引数の関数をラップしたUDF作りたいときは、取り合えず、受けた引数をCreateVectorHにぶっこんで、1次元Variant配列にしてから処理しちゃえば話が簡単になりそうです。

[VBA] EXCELで配列作成関数作ろうとしたら、可変長引数で手間取った話。

CreateVectorH, CreateVectorV

コメント

CreateVectorH, CreateVectorV

関連記事:

コメント