スポンサーリンク
スポンサーリンク
VBA配列の応用操作
これまで何度かにわたってエクセルVBAの配列の入門から、基本操作までを解説してきましたが、今回はVBA配列の高等テクニックを紹介していきたいと思います。
コードは、これまでの入門記事から見ると急に難しくなったように感じるかもしれませんが、ステップを掛けながらローカルウィンドウなどで配列の中身を確認しながら、コードを見ることで理解できると思います。
配列を分割して複数の配列にする
配列をいくつかのパート分けしたい場合があるかと思います。
これを確実に行うにはループ処理を利用します。
次のコードは引数「BaseArray」に指定したバリアント型の１次元配列を「Count」に指定した数ごとに分割したバリアント型の１次元配列を各要素とする二段階配列を返すFunct ionプロシージャです。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 |
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」に指定した添え字の要素を削除して詰めた１次元配列を返します。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 |
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 |
どうですか？
かなり難しいコードに見えますが、やっている事は基本的に配列操作の基本的な内容の組み合わせに過ぎません。
慣れると、この位のコードはスラスラ書けるようになりますので、触って慣れてみてください。
配列の任意の位置に要素を追加
先ほどのサンプルが削除だったので、今度は要素の追加をやっていきましょう。
ここで書くサンプルはループ処理になります。
ループを使うとステップ数が増加してしまいますが、確実で柔軟な処理が可能になります。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 |
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メソッドには、細かな制限が多くあるので、ループで処理できる引き出しを持つことも大切です。
まずはループ処理をご覧ください。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 |
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メソッドを使用してみます。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
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 |
コードは随分すっきりしましたね。
環境に応じて、使い分けてください。
２次元配列の特定行のデータからなる１次元配列を取得
二次元配列の中から１行のみからなる１次元配列を取り出します。
これもやはり、ループ処理を使用するのが確実です。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 |
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 |
まとめ
今回は配列の応用ということで、少し高度なコードを書いて見ました。
理解すると、配列操作が得意になると思いますので是非、理解を深めてください。
配列操作を理解することで、皆さんが書くコードの質、速度などが段違いにレベルアップできると思います。
一緒にがんばっていきましょう。
配列操作の説明は、これで一応おわりです。
今度は、ユーザーフォームの使い方などをやっていきたいな、と思っています。
よろしくお願いします。
リンク
スポンサーリンク
スポンサーリンク
