VBAでJavaScript的な配列を使えるようにするクラス

開発のきっかけ

以前の職場で基本的にVBAを使用していたが、VBAの配列は2次元になったときにまあ使いづらい。
主な原因は要素の追加が最終次元にしかできないこと。つまり行の追加が一発ではできない。
そこを何とかして開発速度を上げるために開発がスタート

この記事はクラスがある程度理解できている方向けに書いています。

自分が使いたい機能を都合の良いように実装しているのでJavaScriptとは動作が違ったり、実装されていない機能が多数あります。

最初はグダグダ標準の方法などが書かれているので、コードが欲しい方は配列のクラスを作成するまで飛んでください。

標準のVBAで2次元配列の行を増やす

処理の内容にもよるかもしれないが、Excelで表をいじるときには行の追加が多いはず。それなのにそれをするのがめんどくさい。
できなくはないので、一応デフォルト方法で行を追加しようとするとこんな感じ。

Sub Array_Test()
    Dim array1
    ReDim array1(1 To 5, 1 To 10)
    
    Debug.Print "Before Rows:" & UBound(array1)
    Debug.Print "Before Cols:" & UBound(array1, 2)
    
    array1 = WorksheetFunction.Transpose(array1)
    
    ReDim Preserve array1(1 To UBound(array1), 1 To UBound(array1, 2) + 1)
    
    array1 = WorksheetFunction.Transpose(array1)
    
    Debug.Print "After Rows:" & UBound(array1)
    Debug.Print "After Cols:" & UBound(array1, 2)
    
End Sub

結果

Before Rows:5
Before Cols:10

After Rows:6
After Cols:10

この方法ではWorksheetFunction.Transposeを使って一度配列の行列を入れ替え、Redim Preserveで内容を維持したまま最終列の要素を増やしてまたRedim Preserveで行列を元に戻すという作業をしている。
一度追加するぐらいなら構わないが、毎回毎回こうやって行を追加してそこにデータを書き込むのは面倒だし、何よりコードが冗長になる。
希望としてはJavaScriptのようにpushで内容を追加したい。
なんなら行別にデータを読み書きできるようにしたい。
というわけでここからが本題

配列のクラスを作成する

とりあえずクラスのコードの全文
処理内容の注釈入りは各種関数、プロパティの説明へ

コード全文

clsArray2

Option Explicit

Private DATA As Variant

Private Sub Class_Terminate()
    DATA = Empty
End Sub


Private Function IsMultiDimension(Contents As Variant) As Boolean
    Dim rtn As Variant
    Err.Clear
    On Error Resume Next
    rtn = UBound(Contents, 2)
    If Err.Number = 0 Then
        IsMultiDimension = True
    End If
    Err.Clear
    On Error GoTo 0
End Function

Private Function OptimizeArray(Contents As Variant) As Variant
    Dim i As Long, j As Long
    Dim clone() As Variant
    
    If IsMultiDimension(Contents) Then
        If LBound(Contents) = 1 And LBound(Contents, 2) = 1 Then
            ReDim clone(0 To UBound(Contents) - 1, 0 To UBound(Contents, 2) - 1) As Variant
        ElseIf LBound(Contents) = 1 Then
            ReDim clone(0 To UBound(Contents) - 1, 0 To UBound(Contents, 2)) As Variant
        ElseIf LBound(Contents, 2) = 1 Then
            ReDim clone(0 To UBound(Contents), 0 To UBound(Contents, 2) - 1) As Variant
        Else
            OptimizeArray = Contents
            Exit Function
        End If
        
        For i = LBound(Contents) To UBound(Contents)
            For j = LBound(Contents, 2) To UBound(Contents, 2)
                clone(i - LBound(Contents), j - LBound(Contents, 2)) = Contents(i, j)
            Next j
        Next i
    Else
        If LBound(Contents) = 1 Then
            ReDim clone(0 To UBound(Contents) - 1) As Variant
        Else
            OptimizeArray = Contents
            Exit Function
        End If
        
        For i = LBound(Contents) To UBound(Contents)
            clone(i - LBound(Contents)) = Contents(i)
        Next i
    End If
    
    OptimizeArray = clone
End Function


Property Get Count(Optional TargetRow_As_Long As Variant) As Long
    If IsEmpty(DATA) Then
        Err.Raise 1200, , "配列が存在しません"
    End If
    Dim i As Long
    Dim buf As Long
    If IsMissing(TargetRow_As_Long) Then
        Count = UBound(DATA) + 1
    ElseIf IsNumeric(TargetRow_As_Long) Then
        If TargetRow_As_Long = -1 Then
            For i = 0 To UBound(DATA)
                If buf < UBound(DATA(i)) Then
                    buf = UBound(DATA(i))
                End If
            Next i
        Else
            buf = UBound(DATA(TargetRow_As_Long))
        End If
        Count = buf + 1
    ElseIf Not IsNumeric(TargetRow_As_Long) Then
        Err.Raise 1100, , "数値で指定してください"
    End If
End Property

Sub AddRow(tRow As Long)
    Dim i As Long
    ReDim Preserve DATA(0 To Me.Count) As Variant
    For i = 1 To UBound(DATA) - tRow
        DATA(Me.Count - i) = DATA(Me.Count - i - 1)
    Next i
    DATA(tRow) = Array()
End Sub

Sub Push(Contents As Variant, Optional TargetRow_As_Long As Variant)
    Dim buf As String
    If Not IsArray(Contents) Then
        Err.Raise 1000, , "配列を渡してください"
    ElseIf IsMultiDimension(Contents) Then
        Err.Raise 1001, , "配列は1次元にしてください"
    End If
    
    Contents = OptimizeArray(Contents)
    
    If IsEmpty(DATA) Then
        DATA = Array(Contents)
    ElseIf IsMissing(TargetRow_As_Long) Then
        ReDim Preserve DATA(0 To Me.Count)
        DATA(UBound(DATA)) = Contents
    ElseIf IsNumeric(TargetRow_As_Long) Then
        If UBound(DATA(TargetRow_As_Long)) = -1 Then
            DATA(TargetRow_As_Long) = Contents
        Else
            buf = Join(Me.RowData(Val(TargetRow_As_Long)), "_Demiliter_") & "_Demiliter_" & Join(Contents, "_Demiliter_")
            Me.RowData(Val(TargetRow_As_Long)) = Split(buf, "_Demiliter_")
        End If
    Else
        Err.Raise 1100, , "数値で指定してください"
    End If
End Sub

Property Let AllData(Optional jsLike As Boolean, Contents As Variant)
    Dim i As Long, j As Long
    Dim RowData() As Variant
    DATA = Empty
    
    If jsLike Then
        If IsArray(Contents(0)) Then
            For i = 0 To UBound(Contents)
                Me.Push Contents(i)
            Next i
        Else
            Me.Push Contents
        End If
    Else
        Contents = OptimizeArray(Contents)
        If IsMultiDimension(Contents) Then
            ReDim RowData(0 To UBound(Contents, 2)) As Variant
            For i = 0 To UBound(Contents)
                For j = 0 To UBound(Contents, 2)
                    RowData(j) = Contents(i, j)
                Next j
                Me.Push RowData
            Next i
        Else
            Me.Push Contents
        End If
    End If
End Property

Property Get AllData(Optional jsLike As Boolean) As Variant
    Dim buf() As Variant
    Dim i As Long, j As Long
    If IsEmpty(DATA) Then
        Exit Property
    End If
    If jsLike Then
        AllData = DATA
    Else
        ReDim buf(0 To Me.Count - 1, 0 To Me.Count(-1) - 1) As Variant
        For i = 0 To Me.Count - 1
            For j = 0 To Me.Count(i) - 1
                buf(i, j) = DATA(i)(j)
            Next j
        Next i
        AllData = buf
    End If
End Property

Sub DeleteRow(tRow As Long)
    Dim i As Long
    For i = tRow To UBound(DATA) - 1
        DATA(i) = DATA(i + 1)
    Next i
    ReDim Preserve DATA(0 To UBound(DATA) - 1) As Variant
End Sub

Property Let CellData(ByVal tRow As Long, ByVal tColumn As Long, Content As Variant)
    If Not IsEmpty(DATA) Then
        DATA(tRow)(tColumn) = Content
    End If
End Property

Property Get CellData(ByVal tRow As Long, ByVal tColumn As Long) As Variant
    If Not IsEmpty(DATA) Then
        CellData = DATA(tRow)(tColumn)
    End If
End Property


Property Let RowData(ByVal tRow As Long, Contents As Variant)
    If Not IsArray(Contents) Then
        Err.Raise 1000, , "配列を渡してください"
    ElseIf IsMultiDimension(Contents) Then
        Err.Raise 1001, , "配列は1次元にしてください"
    End If
    
    DATA(tRow) = Contents
End Property

Property Get RowData(ByVal tRow As Long) As Variant
    RowData = DATA(tRow)
End Property

Function Find(ByVal SearchString As String, Optional FindAll As Boolean) As Variant
    Dim i As Long, j As Long
    Dim formatString As String
    Dim buf As Variant
    For i = 0 To UBound(DATA)
        For j = 0 To UBound(DATA(i))
            formatString = DATA(i)(j)
            If SearchString = formatString Then
                buf = buf & i & "-" & j & ","
                If Not FindAll Then
                    Find = Split(buf, ",")
                    Exit Function
                End If
            End If
        Next j
    Next i
    If IsEmpty(buf) Then
        Find = Array("")
    Else
        Find = Split(buf, ",")
    End If
End Function

インスタンス化、各種コードの使用例

Sub Array_Test2()
    'As Newとすることで作成とインスタンス化を同時に行う
    Dim data As New clsArray2
    
    Dim content As Variant
    Dim contents As Variant
    Dim result As Variant
    
    '配列は全て0スタートのため注意
    
    'シートの内容を配列に一括挿入する
    data.AllData = Worksheets("Sheet1").Range("A1:Z100").Value
    
    '行の最後に内容を追加する
    data.Push Array(1, 2, 3, 4, 5)
    
    '指定した行（第2引数で指定）の列の最後に内容を追加する。
    'この場合2行目の末尾に(10,11,12,13)を追加
    data.Push Array(10, 11, 12, 13), 2

    '指定した行の上に空の行を追加
    data.AddRow 3

    '指定した行を削除する
    data.DeleteRow 2
    
    '指定した行を配列として取得する（この場合1行目の内容を取得）
    contents = data.RowData(1)
    
    '指定した行の内容を上書きする（上書きする内容は1次元の配列にする）
    data.RowData(1) = Array("a", "b", "c", "d")
    
    '指定した位置の内容を取得する　引数は（行、列）
    content = data.CellData(0, 0)
    
    '指定した位置の内容を書き換える
    data.CellData(0, 1) = "a"
    
    '行数を取得する
    result = data.Count
    
    
    '指定した行の列数を取得する（-1を指定すると列の最大値を取得）
    '仕様上、行によって列数が違うことがあるので列数を取得したいときは-1がおすすめ
    Debug.Print data.Count
    Debub.Print data.Count(-1)
    
    '文字列を検索する（完全一致のみ、第二引数を"True"にすることで複数のリストの取得可、
    '結果は行列が"-"で繋がれたものの配列）
    '結果の例　("0-1","3-0")
    
    result = data.Find("a", True)
    
    '配列の内容をシートに書き込む
    Worksheets("Sheet1").Range("A1").Resize(data.Count, data.Count(-1)).Value = data.AllData
End Sub

各種関数、プロパティの説明

IsMultiDimension

仕様上2次元配列が渡されるとエラーを吐くことがあるので、渡された値が1次元かそうではないかの確認。内部処理のためPrivate化

Private Function IsMultiDimension(Contents As Variant) As Boolean
    Dim rtn As Variant
    Err.Clear
    'エラーを吐くか吐かないかで処理をするため、一時中断しないように設定
    On Error Resume Next
    rtn = UBound(Contents, 2)
    '存在しない2次元を取得しようとエラーを吐く仕様を利用。エラーを吐かなった場合2次元以上であることが確定
    If Err.Number = 0 Then
        IsMultiDimension = True
    End If
    Err.Clear
    'エラー処理を通常に戻す
    On Error GoTo 0
End Function

OptimizeArray

このクラス内ではすべての配列を0スタートで処理しているが、受け取った配列が1スタートだった場合（ワークシートの内容を読み取った場合たいてい1スタート）のため0スタートになるように処理している。内部処理のためPrivate化

Private Function OptimizeArray(Contents As Variant) As Variant
    Dim i As Long, j As Long
    Dim clone() As Variant
    
    '次元数によって処理が変わるため分岐
    If IsMultiDimension(Contents) Then
        '行が1スタートの場合、列が1スタートの場合、両方1スタートの場合に合わせてサイズを調整したクローン配列を作成
        If LBound(Contents) = 1 And LBound(Contents, 2) = 1 Then
            ReDim clone(0 To UBound(Contents) - 1, 0 To UBound(Contents, 2) - 1) As Variant
        ElseIf LBound(Contents) = 1 Then
            ReDim clone(0 To UBound(Contents) - 1, 0 To UBound(Contents, 2)) As Variant
        ElseIf LBound(Contents, 2) = 1 Then
            ReDim clone(0 To UBound(Contents), 0 To UBound(Contents, 2) - 1) As Variant
        Else
            'すでに0スタートだった場合処理終了
            OptimizeArray = Contents
            Exit Function
        End If
        'クローンに内容を書き込む
        For i = LBound(Contents) To UBound(Contents)
            For j = LBound(Contents, 2) To UBound(Contents, 2)
                clone(i - LBound(Contents), j - LBound(Contents, 2)) = Contents(i, j)
            Next j
        Next i
    Else
        If LBound(Contents) = 1 Then
            'サイズを調整した配列のクローンを作成
            ReDim clone(0 To UBound(Contents) - 1) As Variant
        Else
            OptimizeArray = Contents
            Exit Function
        End If
        'クローンに内容を書き込む
        For i = LBound(Contents) To UBound(Contents)
            clone(i - LBound(Contents)) = Contents(i)
        Next i
    End If
    '調整した配列を返す。
    OptimizeArray = clone
End Function

Count

行数、列数取得
引数を省略するかどうかで行か列を指定可能。
この関数の内部ではVBA的な2次元配列ではなく、完全にJavaScript的な2次元配列を使用しているため行によって列数が異なることがある。そのため特定の行の列数ではなく、列の最大値を取得できるように特殊引数"-1"を用意

Property Get Count(Optional TargetRow_As_Long As Variant) As Long
    '配列が存在するか確認
    If IsEmpty(DATA) Then
        Err.Raise 1200, , "配列が存在しません"
    End If
    
    Dim i As Long
    Dim buf As Long

    If IsMissing(TargetRow_As_Long) Then
        '引数が存在しない場合、行数を返す
        Count = UBound(DATA) + 1
    '引数が数値か確認
    ElseIf IsNumeric(TargetRow_As_Long) Then
        If TargetRow_As_Long = -1 Then
        '引数が"-1"だった場合すべての行を確認して列数の最大値を取得
            For i = 0 To UBound(DATA)
                If buf < UBound(DATA(i)) Then
                    buf = UBound(DATA(i))
                End If
            Next i
        Else
            '指定された行の列数を取得
            buf = UBound(DATA(TargetRow_As_Long))
        End If
        Count = buf + 1
    '数値以外が渡されていた場合エラー
    ElseIf Not IsNumeric(TargetRow_As_Long) Then
        Err.Raise 1100, , "数値で指定してください"
    End If
End Property

AddRow

指定した位置に空の行を追加する

Sub AddRow(tRow As Long)
    Dim i As Long
    '行数をインクリメント
    ReDim Preserve DATA(0 To Me.Count) As Variant
    For i = 1 To UBound(DATA) - tRow
        '以前の最終行から指定された行まで自身の内容を次の行へコピーする
        DATA(Me.Count - i) = DATA(Me.Count - i - 1)
    Next i
    '追加された位置にある行の中身を空にする
    DATA(tRow) = Array()
End Sub

Push

最終行か、指定された行の列の最後へ内容を書き足す
引数TargetRow_As_Longを省略することで最終行への追加が可能
必ず1次元配列で内容は渡す必要がある。

Sub Push(Contents As Variant, Optional TargetRow_As_Long As Variant)
    Dim buf As String
    '各種エラー対策
    If Not IsArray(Contents) Then
        Err.Raise 1000, , "配列を渡してください"
    ElseIf IsMultiDimension(Contents) Then
        Err.Raise 1001, , "配列は1次元にしてください"
    End If
    
    Contents = OptimizeArray(Contents)
    
    If IsEmpty(DATA) Then
        '自身が空の状態で実行された場合、新たな配列を作成
        DATA = Array(Contents)
    ElseIf IsMissing(TargetRow_As_Long) Then
        '行への追加だった場合自身の行数を追加し、内容を記入
        ReDim Preserve DATA(0 To Me.Count)
        DATA(UBound(DATA)) = Contents
    ElseIf IsNumeric(TargetRow_As_Long) Then
        If UBound(DATA(TargetRow_As_Long)) = -1 Then
            '空の行への追加だった場合はそのまま内容を記入
            DATA(TargetRow_As_Long) = Contents
        Else
            '内容が存在する行への追加だった場合、追加物の内容を末尾に連結させたいが、
            'デミリタとして","などを使うとデータが狂うことがあるので、
            'まず被らないであろう自作デミリタ"_Demiliter_"を使用し内容を分割する。
            '一つの長いテキスト化する
            buf = Join(Me.RowData(Val(TargetRow_As_Long)), "_Demiliter_") & "_Demiliter_" & Join(Contents, "_Demiliter_")
            '作成した文字列を分割し配列に戻す。
            Me.RowData(Val(TargetRow_As_Long)) = Split(buf, "_Demiliter_")
        End If
    Else
        Err.Raise 1100, , "数値で指定してください"
    End If
End Sub

AllData

配列のすべての値を代入したり出力したりするのに使用
引数のjsLikeをTrueにすることでJavaScript的な配列で処理することができる。ただし、Excelで使用することはほぼ無いと思われる

VBA的2次元配列は内容が(x,y)という感じ
JavaScript的な2次元配列は(x)(y)という感じ
詳しくは別途調べてください、、、

Contentsは1次元でも2次元でも大丈夫ですが、必ず配列である必要があります

Property Let AllData(Optional jsLike As Boolean, Contents As Variant)
    Dim i As Long, j As Long
    Dim RowData() As Variant
    DATA = Empty
    
    If jsLike Then
        If IsArray(Contents(0)) Then
            For i = 0 To UBound(Contents)
                Me.Push Contents(i)
            Next i
        Else
            Me.Push Contents
        End If
    Else
        '配列の最適化
        Contents = OptimizeArray(Contents)
        If IsMultiDimension(Contents) Then
            '2次元配列だった場合、各行の内容を"RowData"に代入し配列"RowData"を最終行に追加する
            ReDim RowData(0 To UBound(Contents, 2)) As Variant
            For i = 0 To UBound(Contents)
                For j = 0 To UBound(Contents, 2)
                    RowData(j) = Contents(i, j)
                Next j
                Me.Push RowData
            Next i
        Else
            '1次元だった場合は単純に行を追加
            Me.Push Contents
        End If
    End If
End Property

Property Get AllData(Optional jsLike As Boolean) As Variant
    Dim buf() As Variant
    Dim i As Long, j As Long
    If IsEmpty(DATA) Then
        Exit Property
    End If
    If jsLike Then
        'jsLikeの場合、そのまま内容を出力する
        AllData = DATA
    Else
        '配列の種類をVBA的なものに直してから返す
        ReDim buf(0 To Me.Count - 1, 0 To Me.Count(-1) - 1) As Variant
        For i = 0 To Me.Count - 1
            For j = 0 To Me.Count(i) - 1
                buf(i, j) = DATA(i)(j)
            Next j
        Next i
        AllData = buf
    End If
End Property

DeleteRow

指定された行を削除する

Sub DeleteRow(tRow As Long)
    Dim i As Long
    For i = tRow To UBound(DATA) - 1
        '指定された行から順番に次の行の内容で上書きする
        DATA(i) = DATA(i + 1)
    Next i
    '最終行をデクリメントする
    ReDim Preserve DATA(0 To UBound(DATA) - 1) As Variant
End Sub

CellData

指定した行列の内容を代入、出力

Property Let CellData(ByVal tRow As Long, ByVal tColumn As Long, Content As Variant)
    If Not IsEmpty(DATA) Then
        DATA(tRow)(tColumn) = Content
    End If
End Property

Property Get CellData(ByVal tRow As Long, ByVal tColumn As Long) As Variant
    If Not IsEmpty(DATA) Then
        CellData = DATA(tRow)(tColumn)
    End If
End Property

RowData

指定された行の内容を取得、書き換え
値は必ず配列にする

Property Let RowData(ByVal tRow As Long, Contents As Variant)
    If Not IsArray(Contents) Then
        Err.Raise 1000, , "配列を渡してください"
    ElseIf IsMultiDimension(Contents) Then
        Err.Raise 1001, , "配列は1次元にしてください"
    End If
    
    '指定された行の値を返す
    DATA(tRow) = Contents
End Property

Property Get RowData(ByVal tRow As Long) As Variant
    RowData = DATA(tRow)
End Property

Find

内容の探索
データが存在した場合'行-列'の形で戻されます。

あまり使用を煮詰め切れておらずJavaScriptとは違う挙動をします、、、
まだ使いやすくはない、、、

最初に当たったもののみを返すか、すべてを返すかを選べます。
テキストとしての完全一致のみの検索です。
戻り値は配列です。空白が返された場合データが存在しなかったということになります。

Function Find(ByVal SearchString As String, Optional FindAll As Boolean) As Variant
    Dim i As Long, j As Long
    Dim formatString As String
    Dim buf As Variant
    For i = 0 To UBound(DATA)
        For j = 0 To UBound(DATA(i))
            'Stringに型指定されている変数に値を代入することで、内容をテキスト化
            formatString = DATA(i)(j)
            If SearchString = formatString Then
                '完全一致があった場合、行列をハイフンで繋いで文字列として記録
                buf = buf & i & "-" & j & ","
                If Not FindAll Then
                    '全件検索でなかった場合、文字列を分割して処理終了
                    Find = Split(buf, ",")
                    Exit Function
                End If
            End If
        Next j
    Next i

    If IsEmpty(buf) Then
        'ヒットしなかった場合空の配列を返す
        Find = Array("")
    Else
        '結果の文字列を分割して返す
        Find = Split(buf, ",")
    End If
End Function

終わりに

初投稿のため、粗が目立つかとは思いますので時々書き換えをしてくかもしれません、、