☆Yuus Memo☆
非エンジニアの方でも業務を効率化できるプログラムを紹介します！
VBA

【VBA配列操作：応用編】

  /

VBA配列の応用操作

これまで何度かにわたってエクセルVBAの配列の入門から、基本操作までを解説してきましたが、今回はVBA配列の高等テクニックを紹介していきたいと思います。

コードは、これまでの入門記事から見ると急に難しくなったように感じるかもしれませんが、ステップを掛けながらローカルウィンドウなどで配列の中身を確認しながら、コードを見ることで理解できると思います。

【VBAで配列を使う：実践編①】 VBAでの配列操作　実践編 エクセルVBAの配列操作をシリーズとして記事にしています。配列は難しいイメージが強いですが、使いこな...
Excel VBA
【VBAで配列操作：特殊な配列】 特殊な配列 基本的な配列は下のリンクの記事までで、一通り説明しました。まだ読まれていない方は読んでみてください。 htt...

配列を分割して複数の配列にする

配列をいくつかのパート分けしたい場合があるかと思います。
これを確実に行うにはループ処理を利用します。

次のコードは引数「BaseArray」に指定したバリアント型の１次元配列を「Count」に指定した数ごとに分割したバリアント型の１次元配列を各要素とする二段階配列を返すFunct ionプロシージャです。

Function SplitArray(BaseArray() As Variant _
    , ByVal Count As Long _
    , Optional ByVal Base As Long = 0) As Variant
    Dim myArray() As Variant
    Dim i As Long
    Dim myTmp As Long
    Dim myCnt As Long
    Dim myIdx As Long
    Dim myNewArray() As Variant
    Dim myTmpArray() As Variant
    If Count < 1 Then
        SplitArray1 = CVErr(xlErrValue)
        Exit Function
    End If
    myArray = BaseArray
    On Error Resume Next
    myTmp = UBound(myArray, 2)
    If Err.Number = 0 Then
        '2次元以上の配列が渡されたとき
        SplitArray1 = CVErr(xlErrValue)
        Exit Function
    End If
    On Error GoTo 0
    For i = LBound(myArray) To UBound(myArray)
        myCnt = myCnt Mod Count + 1
        If myCnt = 1 Then
            If i > LBound(myArray) Then
                myNewArray(myIdx) = myTmpArray
                Erase myTmpArray
                myIdx = myIdx + 1
            End If
            ReDim Preserve myNewArray(0 To myIdx) As Variant
        End If
        ReDim Preserve myTmpArray(Base To Base + myCnt - 1) As Variant
        If IsObject(myArray(i)) Then
            Set myTmpArray(Base + myCnt - 1) = myArray(i)
        Else
            myTmpArray(Base + myCnt - 1) = myArray(i)
        End If
    Next
    myNewArray(myIdx) = myTmpArray
    SplitArray = myNewArray
End Function

いかがでしょうか？
ステップ実行などで理解を深めてみてください。

配列の任意の要素を削除する

配列内の任意の要素を削除する場合も、ループで処理するのが確実です。
上のコード同様「BaseArray」に指定した１次元配列から、引数「Index」に指定した添え字の要素を削除して詰めた１次元配列を返します。

Function RemoveArrayItem(BaseArray() As Variant _
    , ByVal Index As Long) As Variant
    Dim myArray() As Variant
    Dim i As Long
    Dim myTmp As Long
    Dim n As Long
    myArray = BaseArray
    On Error Resume Next
    myTmp = UBound(myArray, 2)
    If Err.Number = 0 Then
        '2次元以上の配列が渡されたとき
        RemoveArrayItem1 = CVErr(xlErrValue)
        Exit Function
    End If
    On Error GoTo 0
    If Index >= LBound(myArray) _
        And Index <= UBound(myArray) Then
        n = UBound(myArray) - LBound(myArray) + 1
        If n = 1 Then
            RemoveArrayItem1 = Array()
            Exit Function
        End If
        For i = Index To UBound(myArray) - 1
            If IsObject(myArray(i + 1)) Then
                Set myArray(i) = myArray(i + 1)
            Else
                myArray(i) = myArray(i + 1)
            End If
        Next
        ReDim Preserve myArray(LBound(myArray) _
            To UBound(myArray) - 1) As Variant
    End If
    RemoveArrayItem = myArray
End Function

どうですか？
かなり難しいコードに見えますが、やっている事は基本的に配列操作の基本的な内容の組み合わせに過ぎません。

慣れると、この位のコードはスラスラ書けるようになりますので、触って慣れてみてください。

配列の任意の位置に要素を追加

先ほどのサンプルが削除だったので、今度は要素の追加をやっていきましょう。
ここで書くサンプルはループ処理になります。

ループを使うとステップ数が増加してしまいますが、確実で柔軟な処理が可能になります。

Function AddArrayItem(BaseArray() As Variant _
    , AddValue As Variant, Optional ByVal Index As Variant) As Variant
    Dim myArray() As Variant
    Dim i As Long
    Dim myTmp As Long
    Dim myIndex As Long
    myArray = BaseArray
    On Error Resume Next
    myTmp = UBound(myArray, 2)
    If Err.Number = 0 Then
        '2次元以上の配列が渡されたとき
        AddArrayItem1 = CVErr(xlErrValue)
        Exit Function
    End If
    Err.Clear
    If IsMissing(Index) Then
        'Indexが省略されたとき
        myIndex = UBound(myArray) + 1
    ElseIf Index < LBound(myArray) Or Index > UBound(myArray) + 1 Then
        'Indexの値が範囲外のとき
        myIndex = UBound(myArray) + 1
    Else
        myIndex = CLng(Index)
    End If
    If Err.Number <> 0 Then
        'Indexに不正な値や参照が渡されたとき
        myIndex = UBound(myArray) + 1
    End If
    On Error GoTo 0
    ReDim Preserve myArray(LBound(myArray) _
        To UBound(myArray) + 1) As Variant
    For i = UBound(myArray) To myIndex + 1 Step -1
        If IsObject(myArray(i - 1)) Then
            Set myArray(i) = myArray(i - 1)
        Else
            myArray(i) = myArray(i - 1)
        End If
    Next
    If IsObject(AddValue) Then
        Set myArray(i) = AddValue
    Else
        myArray(i) = AddValue
    End If
    AddArrayItem = myArray
End Function

削除を理解できた方は簡単に理解できるかと思います。

上の３つのサンプルは慣れると非常に便利なものになっています。
関数化してあるのもその為です。

皆さんも是非、自分なりにアレンジして使ってください。

２次元配列の行列を入れ替える

２次元配列の行列の入れ替えで真っ先に思い浮かぶのは「 Transeposeメソッド」を使用したものだと思います。

ただ、Transepooseメソッドには、細かな制限が多くあるので、ループで処理できる引き出しを持つことも大切です。

まずはループ処理をご覧ください。

Function Transpose2DArray1(BaseArray() As Variant) As Variant
    Dim myArray() As Variant
    Dim myTmp As Long
    Dim myNewArray() As Variant
    Dim x As Variant
    Dim i As Long, j As Long
    myArray = BaseArray
    On Error Resume Next
    myTmp = UBound(myArray, 2)
    If Err.Number <> 0 Then
        '一次元配列が渡されたとき
        On Error GoTo 0
        i = LBound(myArray)
        ReDim myNewArray(LBound(myArray) To UBound(myArray), 0 To 0) As Variant
        For Each x In myArray
            If IsObject(x) Then
                Set myNewArray(i, 0) = x
            Else
                myNewArray(i, 0) = x
            End If
            i = i + 1
        Next
        Transpose2DArray1 = myNewArray
        Exit Function
    End If
    myTmp = UBound(myArray, 3)
    If Err.Number = 0 Then
        '3次元以上の配列が渡されたとき
        Transpose2DArray1 = CVErr(xlErrValue)
        Exit Function
    End If
    On Error GoTo 0
    ReDim myNewArray(LBound(myArray, 2) To UBound(myArray, 2) _
        , LBound(myArray, 1) To UBound(myArray, 1)) As Variant
    For i = LBound(myArray, 1) To UBound(myArray, 1)
        For j = LBound(myArray, 2) To UBound(myArray, 2)
            If IsObject(myArray(i, j)) Then
                Set myNewArray(j, i) = myArray(i, j)
            Else
                myNewArray(j, i) = myArray(i, j)
            End If
        Next
    Next
    Transpose2DArray1 = myNewArray
End Function

続いて、 Transepoosメソッドを使用してみます。

Function Transpose2DArray2(BaseArray() As Variant) As Variant
    Dim myArray() As Variant
    Dim myTmp As Long
    Dim x As Variant
    myArray = BaseArray
    On Error Resume Next
    myTmp = UBound(myArray, 3)
    If Err.Number = 0 Then
        '3次元以上の配列が渡されたとき
        Transpose2DArray2 = CVErr(xlErrValue)
        Exit Function
    End If
    On Error GoTo 0
    For Each x In myArray
        If IsArray(x) Or IsObject(x) Then
            '配列の要素に配列やオブジェクトへの参照が含まれるとき
            Transpose2DArray2 = CVErr(xlErrValue)
            Exit Function
        End If
    Next
    Transpose2DArray2 = WorksheetFunction.Transpose(myArray)
End Function

コードは随分すっきりしましたね。

環境に応じて、使い分けてください。

２次元配列の特定行のデータからなる１次元配列を取得

二次元配列の中から１行のみからなる１次元配列を取り出します。

これもやはり、ループ処理を使用するのが確実です。

Function Choice1DArray1(BaseArray() As Variant _
    , Optional RowIndex As Variant) As Variant
    Dim myArray() As Variant
    Dim myRowIndex As Long
    Dim myTmp As Long
    Dim myNewArray() As Variant
    Dim i As Long
    myArray = BaseArray
    On Error Resume Next
    myTmp = UBound(myArray, 2)
    If Err.Number <> 0 Then
        '1次元配列が渡されたとき
        Choice1DArray1 = CVErr(xlErrValue)
        Exit Function
    End If
    myTmp = UBound(myArray, 3)
    If Err.Number = 0 Then
        '3次元以上の配列が渡されたとき
        Choice1DArray1 = CVErr(xlErrValue)
        Exit Function
    End If
    On Error GoTo 0
    If IsMissing(RowIndex) Then
        'RowIndexが省略されたとき
        myRowIndex = LBound(myArray, 1)
    ElseIf IsNumeric(RowIndex) Then
        myRowIndex = CLng(RowIndex)
        If myRowIndex < LBound(myArray, 1) Or myRowIndex > UBound(myArray, 1) Then
            'RowIndexの値が範囲外のとき
            myRowIndex = LBound(myArray, 1)
        End If
    Else
        'RowIndexに不正な値や参照が渡されたとき
        Choice1DArray1 = CVErr(xlErrValue)
        Exit Function
    End If
    ReDim myNewArray(LBound(myArray, 2) To UBound(myArray, 2)) As Variant
    For i = LBound(myArray, 2) To UBound(myArray, 2)
        If IsObject(myArray(myRowIndex, i)) Then
            Set myNewArray(i) = myArray(myRowIndex, i)
        Else
            myNewArray(i) = myArray(myRowIndex, i)
        End If
    Next
    Choice1DArray1 = myNewArray
End Function

Function Choice1DArray2(BaseArray() As Variant _
    , Optional RowIndex As Variant) As Variant
    Dim myArray() As Variant
    Dim myTmp As Long
    Dim myRowIndex As Long
    Dim x As Variant
    myArray = BaseArray
    On Error Resume Next
    myTmp = UBound(myArray, 2)
    If Err.Number <> 0 Then
        '1次元配列が渡されたとき
        Choice1DArray2 = CVErr(xlErrValue)
        Exit Function
    End If
    myTmp = UBound(myArray, 3)
    If Err.Number = 0 Then
        '3次元以上の配列が渡されたとき
        Choice1DArray2 = CVErr(xlErrValue)
        Exit Function
    End If
    On Error GoTo 0
    If IsMissing(RowIndex) Then
        'RowIndexが省略されたとき
        myRowIndex = LBound(myArray, 1)
    ElseIf IsNumeric(RowIndex) Then
        myRowIndex = CLng(RowIndex)
        If myRowIndex < LBound(myArray, 1) Or myRowIndex > UBound(myArray, 1) Then
            'RowIndexの値が範囲外のとき
            myRowIndex = LBound(myArray, 1)
        End If
    Else
        'RowIndexに不正な値や参照が渡されたとき
        Choice1DArray2 = CVErr(xlErrValue)
        Exit Function
    End If
    For Each x In myArray
        If IsArray(x) Or IsObject(x) Then
            '配列の要素に配列やオブジェクトへの参照が含まれるとき
            Choice1DArray2 = CVErr(xlErrValue)
            Exit Function
        End If
    Next
    myRowIndex = myRowIndex - LBound(myArray, 1) + 1
    Choice1DArray2 = WorksheetFunction.Index(myArray, CDbl(myRowIndex))
End Functio

まとめ

今回は配列の応用ということで、少し高度なコードを書いて見ました。
理解すると、配列操作が得意になると思いますので是非、理解を深めてください。

配列操作を理解することで、皆さんが書くコードの質、速度などが段違いにレベルアップできると思います。

一緒にがんばっていきましょう。

配列操作の説明は、これで一応おわりです。
今度は、ユーザーフォームの使い方などをやっていきたいな、と思っています。
よろしくお願いします。

Array VBA
あわせて読みたい

コメントを残す