もくじ
VBA配列の応用操作
これまで何度かにわたってエクセルVBAの配列の入門から、基本操作までを解説してきましたが、今回はVBA配列の高等テクニックを紹介していきたいと思います。
コードは、これまでの入門記事から見ると急に難しくなったように感じるかもしれませんが、ステップを掛けながらローカルウィンドウなどで配列の中身を確認しながら、コードを見ることで理解できると思います。
配列を分割して複数の配列にする
配列をいくつかのパート分けしたい場合があるかと思います。
これを確実に行うにはループ処理を利用します。
次のコードは引数「BaseArray」に指定したバリアント型の1次元配列を「Count」に指定した数ごとに分割したバリアント型の1次元配列を各要素とする二段階配列を返す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」に指定した1次元配列から、引数「Index」に指定した添え字の要素を削除して詰めた1次元配列を返します。
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
削除を理解できた方は簡単に理解できるかと思います。
上の3つのサンプルは慣れると非常に便利なものになっています。
関数化してあるのもその為です。
皆さんも是非、自分なりにアレンジして使ってください。
2次元配列の行列を入れ替える
2次元配列の行列の入れ替えで真っ先に思い浮かぶのは「 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
コードは随分すっきりしましたね。
環境に応じて、使い分けてください。
2次元配列の特定行のデータからなる1次元配列を取得
二次元配列の中から1行のみからなる1次元配列を取り出します。
これもやはり、ループ処理を使用するのが確実です。
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
まとめ
今回は配列の応用ということで、少し高度なコードを書いて見ました。
理解すると、配列操作が得意になると思いますので是非、理解を深めてください。
配列操作を理解することで、皆さんが書くコードの質、速度などが段違いにレベルアップできると思います。
一緒にがんばっていきましょう。
配列操作の説明は、これで一応おわりです。
今度は、ユーザーフォームの使い方などをやっていきたいな、と思っています。
よろしくお願いします。