・はじめに
VBAで最近ツールを作る機会が多いのですが、古い言語だけあって機能があまり充実していません、特に配列に関する処理が現代の言語には当たり前にある機能が標準ではほとんどないためコーディングに不便を感じることもしばしば
そこで汎用的な関数(プロシージャ)を作成してそれらの機能を再現することで不便さを緩和しています
配列以外にも、コレクションと二次元配列の操作用関数も含んでいます
JavaScriptのArrayのメソッド、Pythonのリストのメソッドをヒントに作成しており、元にしたPythonのコードも一部載せています
解説部分で関数自体のコードをそのまま記述すると長くなってしまうので各関数は簡易的な記法で引数・戻り値と型、使用例のみの記載にしてます
ソースコード全体は下のほうに載せていますので標準モジュールまたはクラスモジュールにそのままコピーペーストして使用してください
クラスモジュールで使用する場合インスタンスを作成する必要がありますが、エラートラップの仕様上関数の呼び出し元の行で処理が止まるのでデバッグが楽になります
注意点として、いくつかの関数は同じコード内の関数に依存しているので目的の関数のみを単体でコピー&ペーストしても動作しません
VBAはObject型の扱いが特殊(代入で「Set」を使わないといけなかったり、=で比較できない)でAIの出力コードもオブジェクト対応してないことがよくありますがこの関数は対応済です
また、検索系(ContainsValue, ArrayIndexOfなど)や重複削除系(ArrayRemoveDuplicatesなど)の関数は元となったPython, JavaScriptの仕様に則り型を厳密に比較します
ただしInteger, Long, Doubleを別の値として扱うとさすがに不便なので数字は文字列かそれ以外かの判定を行っています
また、これらの関数ではセルの値をRange("A1")のように代入するとオブジェクト扱いされてしまうのでRange("A1").Valueのように必ず.Valueを省略せずつけてください
比較の挙動の詳しい仕様を知りたい場合ソースコード内の関数IsStrictlyEqualとGenerateCollKeyを確認してください
本記事、および本ソースコードの自由利用を歓迎します(0BSDライセンス)、この記事自体をAIに読み込ませてコーディングしても面白いかもしれません
※ 2026-3-25追記
2026-3-25のバージョン以降、ArrayMap, ArrayMap2, ArrayMap3の引数仕様に破壊的変更があります
変更内容: 引数の順序を変更
旧仕様(2026-3-23まで):
arr, procName, ParamArray args() (ArrayMap, ArrayMap3)
arr, obj, procName, ParamArray args() (ArrayMap2)
新仕様(2026-3-25以降):
procName, arr, ParamArray args() (ArrayMap, ArrayMap3)
obj, procName, arr, ParamArray args() (ArrayMap2)
変更理由: ユーザーがArrayMapをArrayMap2(またはその逆)に置き換える作業を単純な文字列置換で容易にできるようにするため
およびPythonのmap, PHPのarray_mapの引数仕様が(関数, 配列)のためその仕様に合わせた
・関数一覧
ArrayLength
QuickSortArray
InsertionSortArray
InsertionSortJaggedArray
InsertionSortJaggedArray2
MergeSortJaggedArray
ReverseArray
ArrayIndexOf
ArrayIndexOf2
ConcatArrays
ConcatArrays2
ExtendArray
ArrayPush
SliceArray
ArrayInsert
ArrayRemoveIndex
ArrayRemoveValue
FilterArrayByIndexes
OffsetArray
ResizeArray
ArrayMax
ArrayMin
ArraySum
ArrayAverage
ArrayMedian
ArrayMap
ArrayMap2
ArrayMap3
IsInitializedArray
ArrayEquals
ReplaceValueInArray
GetMissingNumbers
ArrayDuplicateIndexes
ArrayRemoveDuplicates
ContainsValue
CountValues
IsIterable
IterableCount
CreateColl
ArrayToCollection
CollectionToArray
NestedCollectionToArray
CollContainsKey
ReverseCollection
QuickSortCollection
ExtendCollection
ConcatCollections
ConcatCollections2
CollRemoveValue
CollRemoveDuplicates
Reverse2DArrayV
Reverse2DArrayH
Transpose2DArray
TransposeJaggedArray
Array1DTo2DV
Array1DTo2DH
Concat2DArraysV
Concat2DArraysH
Offset2DArray
Slice2DArray
Resize2DArray
Extract2DArrayCol
Extract2DArrayRow
ArrayJaggedTo2D
Array2DToJagged
Paste1DArrayTo2DArrayV
Paste1DArrayTo2DArrayH
MergeSort2DArray
Array2DRemoveRowIndex
Array2DRemoveColIndex
Filter2DArrayByRowIndexes
Filter2DArrayByColIndexes
ReplaceValueIn2DArray
Paste2DArrayToCell
・配列の長さを取得
Function ArrayLength(arr, dimentionNum=1)
arr: [Variant][Array] (ByRef) 要素数を測る配列
dimentionNum: [Long]
配列の長さを測る次元を指定
1 -> 一次元配列の長さまたは二次元配列の行数
2 -> 二次元配列の列数
戻り値: [Long] 配列の長さ、未初期化配列に対しては0を返す
※ ByRefで配列を渡す関係上、別のプロシージャのParamArrayをそのまま渡すとエラーになるのでその場合CVarで囲む必要がある
使用例
Dim a As Long
a = ArrayLength(Array(1, 2, 3)) '3
Pythonでは以下のコードに相当します
a = len([1, 2, 3]) # 3
・配列をソート
QuickSortArrayは不安定ソート(同じ数値の場合元の順序を保証しない)ですがとても高速
InsertionSortArrayは安定ソートですが遅いです
一次元配列のソートなのでQuickSortArrayで大半の用途は事足ります
Sub QuickSortArray(arr, reverse=False, strSort=False, ignoreCase=True)
arr:[Variant][Array] ソート対象の配列(ByRef)
reverse:[Boolean] Trueで降順ソートする
strSort:[Boolean] Trueで文字列基準ソート、Falseで数値基準ソート
ignoreCase:[Boolean] TrueでstrSort:=Trueの場合に大文字、小文字を区別しないで比較する
Sub InsertionSortArray(arr, reverse=False, strSort=False, ignoreCase=True)
引数はQuickSortArrayと同様
使用例
Dim arr
arr = Array(1, 3, 2)
Call QuickSortArray(arr) ' [1, 2, 3]
Pythonでは以下のコードに相当します
lst = [1, 3, 2]
lst.sort()
・ジャグ配列のソート(挿入ソート)
ジャグ配列(入れ子の配列)をソートします、挿入ソートなので安定ですが速度は遅いです
基本的にMergeSortJaggedArrayの使用を推奨します(高速かつ安定ソート)
一応作ったので載せてますがInsertionSortは遅いので使用推奨しません
Sub InsertionSortJaggedArray(arr, reverse=False, strSort=False, ignoreCase=True)
ネストされた配列の一番最初のインデックスを基準にソートを行う
arr:[Variant][Array] ソート対象の配列(ByRef)
reverse:[Boolean] Trueで降順ソートする
strSort:[Boolean] Trueで文字列基準ソート、Falseで数値基準ソート
ignoreCase:[Boolean] TrueでstrSort:=Trueの場合に大文字、小文字を区別しないで比較する
・ジャグ配列のソート(挿入ソートその2)
Sub InsertionSortJaggedArray2(arr, keyIndex, reverse=False, strSort=False, ignoreCase=True, sortFrom=Null, sortTo=Null)
InsertionSortJaggedArrayの拡張版
arr:[Variant][Array] ソート対象の配列(ByRef)
keyIndex:[Variant][Long/Null] Nullで各配列の最初のインデックスの要素, 数字で各配列の指定のインデックスの要素をキーにソート
reverse:[Boolean] Trueで降順ソートする
strSort:[Boolean] Trueで文字列基準ソート、Falseで数値基準ソート
ignoreCase:[Boolean] TrueでstrSort:=Trueの場合に大文字、小文字を区別しないで比較する
sortFrom, sortTo:[Variant][Long/Null] 外側の配列のソート範囲のインデックス(どこからどこまでソートするか)を指定可能、Nullで配列の下限(sortFrom)と上限(sortTo)
呼び出し例
Dim arr1, arr2
arr1 = Array(Array(1, 1), Array(3, 2), Array(2, 3))
arr2 = Array(Array(1, 1), Array(3, 2), Array(2, 3))
Call InsertionSortJaggedArray(arr1)
Call InsertionSortJaggedArray2(arr2, 1)
・ジャグ配列のソート(マージソート)
高速かつ安定ソートなので、基本的にこちらでソートするといいです
Function MergeSortJaggedArray(arr, keyIndex=Null, reverse=False, strSort=False, ignoreCase=True, header=False, sortFrom=Null, sortTo=Null)
arr:[Variant][Array] ソート対象の配列
keyIndex: [Variant][Array/Long/Null]
keyIndexはソート基準のネストされた配列のインデックスを数字そのままか配列かNullを指定、Nullで各配列の最小インデックス
配列を指定した場合配列の最初のほうの要素ほどソートの優先度が高い
例えばArray(Null, 2, 3)を指定した場合3, 2基準でソート後一番最初のインデックス基準でソートされる
オブジェクトなど、比較できないものが入っているインデックスを指定するとエラーになる
reverse: [Boolean]Trueで降順ソートする
strSort:[Boolean] Trueで文字列基準ソート、Falseで数値基準ソート
ignoreCase:[Boolean] TrueでstrSort:=Trueの場合に大文字、小文字を区別しないで比較する
header:[Boolean] Trueで1番最初の行をソート対象に入れない
sortFrom:[Variant][Long/Null] ソート対象行の開始インデックス, Null/数字、Null指定時は最小インデックス、数字指定時はheader指定を無視
sortTo: [Variant][Long/Null] ソート対象行の終了インデックス、Null指定時は最大インデックス
戻り値: [Variant()] ソート後の配列
例1: keyIndex:=1, sortFrom:=Null, sortTo:=Null
[[3, 2], [1, 1], [2, 3]] -> [[1, 1], [3, 2], [2, 3]]
例2: keyIndex:=0, sortFrom:=1, sortTo:=Null
[[2, 3], [3, 1], [1, 2]] -> [[2, 3], [1, 2], [3, 1]]
例3: keyIndex:=1, sortFrom:=0, sortTo:=1
[[2, 3], [3, 1], [1, 2]] -> [[3, 1], [2, 3], [1, 2]]
同じ数値同士の並び順には影響を与えない
例4: keyIndex:=0, sortFrom:=Null, sortTo:=Null
[[3, 3], [3, 1], [1, 1], [3, 2]] -> [[1, 1], [3, 3], [3, 1], [3, 2]]
MergeSortJaggedArrayで複数のキーでソートする例
Dim arr
arr = Array(Array(1, 1), Array(3, 2), Array(2, 3))
arr = MergeSortJaggedArray(arr, Array(0, 1))
このコードはPythonでは以下のソート方法に対応します
arr = [[1, 1], [3, 2], [2, 3]]
arr.sort(key=lambda x: (x[0], x[1]))
・配列を反転
Function ReverseArray(arr)
arr:[Variant(Array)] 対象の配列
戻り値: [Variant()] 反転した配列
使用例
Dim arr
arr = Array(1, 2, 3)
arr = ReverseArray(arr) '[3, 2, 1]
Pythonでの対応するコード
arr = [1, 2, 3]
arr.reverse()
・配列の指定した要素のインデックスを返す
Function ArrayIndexOf(arr, value, startIndex=Null, endIndex=Null)
配列の中にある指定要素の最初のインデックスを返す、要素がなければエラー、Integer,Double,Longなどの数値を除き型一致の場合のみ同じ要素とみなす
配列を指定した場合は同じ配列でも一致判定をしない、オブジェクト型の場合同じ参照のオブジェクトの場合に一致と判定する
arr:[Variant][Array] 対象の配列
value: [Variant]: 検索する値
startIndex: [Variant][Long/Null] 検索範囲開始インデックス、Nullで与えられた配列の最小インデックス
endIndex: [Variant][Long/Null] 検索範囲終了インデックス、Nullで与えられた配列の最大インデックス
戻り値: [Long] 見つかった要素のインデックス
※数値以外は厳密な型比較を行う
※ジャグ配列には未対応、オブジェクトは参照先アドレス一致の場合同じ値と判定
使用例
Dim arr, i As Long, i2 As Long
arr = Array(1, 2, 3, 1, 3, 2)
i = ArrayIndexOf(arr, 3)
Debug.Print i ' 2
i2 = ArrayIndexOf(arr, 3, 3, 5)
Debug.Print i2 ' 4
Pythonでの対応するコード
arr = [1, 2, 3, 1, 3, 2]
i = arr.index(3)
print(i) # 2
i2 = arr.index(3, 3, 5)
print(i2) # 4
数値と文字列のように型が違うと同じ値として扱われません
この場合は配列に"3"がないのでエラーになります
Dim arr, i As Long
arr = Array(1, 2, 3, 1, 3, 2)
i = ArrayIndexOf(arr, "3") ' エラー
・配列の指定した要素のインデックスを返す(要素を複数指定可、かつ一致するインデックスをすべて返す)
Function ArrayIndexOf2(arr, valueList, startIndex=Null, endIndex=Null)
arr:[Variant][Array] 検索したい要素のリストを配列/コレクションで指定
valueList: [Variant][Array/Collection]: 検索する値
startIndex: [Variant][Long/Null] 検索範囲開始インデックス、Nullで与えられた配列の最小インデックス
endIndex: [Variant][Long/Null] 検索範囲終了インデックス、Nullで与えられた配列の最大インデックス
戻り値: [Variant()] 見つかったインデックスの配列、一致するインデックスがない場合は空の配列を返す
※数値以外は厳密な型比較を行う
※ジャグ配列には未対応、オブジェクトは参照先アドレス一致の場合同じ値と判定
実行例1: ArrayIndexOf2(Array(1, 2, 3, 1, 4), Array(1, 2)) -> [0, 1, 3]
実行例2: ArrayIndexOf2(Array(1, 2, 3, 1, 4), Array(1)) -> [0, 3]
・配列同士を結合
Function ConcatArrays(ParamArray arraysToConcat())
arraysToConcat: [可変長引数][Variant][Array] 結合したい配列を引数に順番に指定、結合数に明確な制限はなし
戻り値: [Variant()] 結合後の配列(開始のインデックスは0)
使用例
Dim result, arr1, arr2
arr1 = Array(1, 2, 3)
arr2 = Array(4, 5, 6)
result = ConcatArrays(arr1, arr2) ' [1, 2, 3, 4, 5, 6]
Pythonでは以下のコードに相当します
arr1 = [1, 2, 3]
arr2 = [4, 5, 6]
result = arr1 + arr2
・配列同士を結合(結合対象を配列かコレクションで指定)
ConcatArraysのParamArrayを配列/コレクション指定に置き換えたバージョンです、加えて戻り値の配列の開始インデックスを指定できます
Function ConcatArrays2(arraysToConcat, firstIndex=0)
arraysToConcat:[Variant][Array/Collection] 結合したい配列を格納した配列またはコレクションを指定
firstIndex:[Long] 作成される配列の開始インデックスを指定(デフォルト0)
戻り値: [Variant()] 結合後の配列
使用例
Dim result, arr1, arr2
arr1 = Array(1, 2, 3)
arr2 = Array(4, 5, 6)
result = ConcatArrays2(Array(arr1, arr2), 0) ' [1, 2, 3, 4, 5, 6]
・配列に別の配列を結合(元の配列を変更)
Sub ExtendArray(originalArr, additionalArr)
originalArr(ByRef):[Variant][Array] 変更対象の配列
additionalArr:[Variant][Array] 結合する配列
使用例
Dim arr
arr = Array(1, 2, 3)
Call ExtendArray(arr, Array(4, 5, 6)) ' [1, 2, 3, 4, 5, 6]
Pythonでは以下のコードに相当します
arr = [1, 2, 3]
arr.extend([4, 5, 6])
・動的配列に要素を追加
メモリ再割り当てもありかなり遅いので頻繁な追加をするならコレクションにまとめて追加してからCollectionToArrayを使用して配列に変換したほうがいいです
Sub ArrayPush(arr, value)
arr(ByRef):[Variant][Array] 対象の配列
value:[Variant] 追加する値
動的配列の最後に値を追加する、静的配列に追加しようとするとエラー
空配列、未初期化配列ならインデックス0に要素を代入
使用例
Dim arr
arr = Array(1, 2, 3)
Call ArrayPush(arr, 4) ' [1, 2, 3, 4]
Pythonでは以下のコードに相当します
arr = [1, 2, 3]
arr.append(4)
・配列をスライス
Function SliceArray(arr, startIndex, endIndex)
arr:[Variant][Array] スライス対象の配列
startIndex:[Long] スライス開始インデックス(それ自体を含む)
endindex:[Long] スライス終了インデックス(それ自体を含む)
戻り値:[Variant()] スライスされた配列
使用例
Dim arr, result
arr = Array(1, 2, 3, 4, 5, 6)
result = SliceArray(arr, 2, 4) ' [3, 4, 5]
Pythonでは以下のコードに相当します
終了インデックスをスライス範囲に含めるか含めないかが異なります
SliceArray関数のほうはVBの設計思想に従い、含めるようにしました
arr = [1, 2, 3, 4, 5, 6]
result = arr[2:5]
print(result)
・配列に要素を挿入
Function ArrayInsert(arr, index, value)
arr:[Variant][Array] 挿入対象の配列
index:[Long] 挿入位置のインデックス
value:[Variant] 挿入する値
戻り値:[Variant()] 要素が挿入された配列
※開始インデックス番号は維持される
※要素数0の配列では動作するが、未初期化配列の場合はエラー
使用例
Dim arr
arr = Array("apple", "orange", "banana")
arr = ArrayInsert(arr, 2, "cherry") ' ["apple", "orange", "cherry", "banana"]
Pythonでは以下のコードに相当します
元の配列を変更するか、新しい配列を返すかで異なります
arr = ["apple", "orange", "banana"]
arr.insert(2, "cherry")
・配列の指定インデックスを削除
Function ArrayRemoveIndex(arr, targetIndex)
arr:[Variant][Array] 対象の配列
targetIndex:[Variant][Long/Array/Collection] 削除するインデックスを数字または数字の配列/コレクションで指定
戻り値:[Variant()] インデックス削除後の配列
使用例
Dim result
result = ArrayRemoveIndex(Array("A","B","C","D","E"), 1) ' ["A","C","D","E"]
result = ArrayRemoveIndex(Array("A","B","C","D","E"), Array(0, 2, 4)) ' ["B", "D"]
result = ArrayRemoveIndex(Array("A","B","C","D","E"), Array(0, 1, 2, 3, 4)) '[]
・配列の指定要素を削除
Rubyのarray.delete(value)と同様、複数の値がヒットした場合はすべて削除します
最初にヒットした値のみを削除したい場合はArrayIndexOf+ArrayRemoveIndexを使用してください
Function ArrayRemoveValue(arr, value)
arr:[Variant][Array] 対象の配列
value:[Variant] 削除する要素
戻り値:[Variant()] 要素削除後の配列
※ valueと一致する要素が複数ある場合、すべて削除する
※ 削除対象の値が1つも入っていない場合はエラーになる
※ 削除判定のさい数値以外は厳密な型比較を行う
※ ジャグ配列には未対応、オブジェクトは参照先アドレス一致の場合同じ値と判定
使用例
Dim result
result = ArrayRemoveValue(Array(1, 2, 3, 1), 1) '[2, 3]
result = ArrayRemoveValue(Array("", Empty, Empty, 0), Empty) '["", 0]
・配列の開始インデックスを変更
Function OffsetArray(arr, newFirstIdx)
arr:[Variant][Array] 対象の配列
newFirstIdx:[Long] 新しい開始インデックス
戻り値:[Variant()] 開始インデックスを変更後の配列
使用例
Dim arr, result
arr = Array(1, 2, 3)
Debug.Print LBound(arr) & ", " & UBound(arr) '0, 2
result = OffsetArray(arr, 1)
Debug.Print LBound(result) & ", " & UBound(result) '1, 3
result = OffsetArray(arr, 2)
Debug.Print LBound(result) & ", " & UBound(result) '2, 4
備考: 関数名はJuliaの同様の機能の関数に由来しています
・配列の要素のインデックスを維持したままサイズを変更
Function ResizeArray(arr, lowerIdx, upperIdx)
arr:[Variant][Array] 対象の配列
lowerIdx:[Long] 変更後最小インデックス
upperIdx:[Long] 変更後最大インデックス
戻り値:[Variant()] リサイズ後の配列
使用例
Dim arr, result
arr = Array("A", "B", "C", "D")
result = ResizeArray(arr, -3, 4) '[Empty, Empty, Empty, "A", "B", "C", "D", Empty]
Debug.Print LBound(result) & ", " & UBound(result) '-3, 4
result = ResizeArray(arr, 1, 2) '["B", "C"]
Debug.Print LBound(result) & ", " & UBound(result) '1, 2
・配列の最大値、最小値、合計、平均、中央値を求める
最大値を求める
Function ArrayMax(arr)
最小値を求める
Function ArrayMin(arr)
合計値を求める
Function ArraySum(arr)
平均を求める
Function ArrayAverage(arr)
中央値を求める
Function ArrayMedian(arr)
arr:[Variant][Array] 対象の配列
戻り値:[Double] 計算結果
※数値以外のデータが配列に含まれているとエラーになる、ただしBoolean型とDate型はエラーにならない
使用例
Dim arr
arr = Array(100, -1, 0, 20)
Debug.Print ArrayMax(arr) '100
Debug.Print ArrayMin(arr) '-1
Debug.Print ArraySum(arr) '119
Debug.Print ArrayAverage(arr) '29.75
Debug.Print ArrayMedian(arr) '10
Pythonでの対応するコードは以下になります
import statistics
arr = [100, -1, 0, 20]
print(max(arr)) # 100
print(min(arr)) # -1
print(sum(arr)) # 119
print(statistics.mean(arr)) # 29.75
print(statistics.median(arr)) # 10.0
・配列内の各要素に関数の結果を適用
Pythonのmap関数に相当する機能の関数です
内部でApplication.Runを使う関係上速度が落ちるので気になる方はArrayMap2のほうを使ってください
Function ArrayMap(procName, arr, ParamArray args())
procName:[String] 関数の名前を文字列で指定、Publicで定義したユーザー定義関数のみ指定可能
指定する関数は第一引数に配列の各要素を受け取る必要がある
呼び出せない関数でもラッパーを作れば間接的に呼び出せる
arr:[Variant][Array] 対象の配列
args: [可変長引数][Variant] procNameで指定した関数の第二引数以降を指定(省略可、最大10個まで)
戻り値:[Variant()] 関数の結果を適用した配列
使用例
Dim arr, result
arr = Array(Array(1, 2, 3), Array(), Array(5))
result = ArrayMap("ArrayLength", arr) '[3, 0, 1]
Debug.Print Join(result, ", ")
組み込み関数はそのままでは呼び出せないのでラッパー関数を作成してください
' TypeNameのラッパーを作成
Function MyTypeName(ByVal value As Variant) As String
MyTypeName = TypeName(value)
End Function
Sub test()
Dim arr, result
arr = Array(1, "a", Nothing, Array(1, 2), True)
result = ArrayMap("MyTypeName", arr) ' [Integer, String, Nothing, Variant(), Boolean]
Debug.Print Join(result, ", ")
End Sub
第2引数以降も指定できます(最大第11引数まで)
Function Add(ByVal value1 As Long, ByVal value2 As Long, ByVal value3 As Long) As Long
Add = value1 + value2 + value3
End Function
Sub test()
Dim arr, result
arr = Array(1, 2, 3, 4, 5)
result = ArrayMap("Add", arr, 1, 2) ' [4, 5, 6, 7, 8]
Debug.Print Join(result, ", ")
End Sub
・配列内の各要素を第一引数としたメソッド/プロパティの結果を適用
配列の各要素を第一引数としてとるCOMオブジェクトやクラスのメソッド、プロパティの結果を適用した結果の配列を返します。
ArrayMapより10倍以上高速ですが標準モジュールに定義した関数は直接呼び出せません。
クラスメソッドかワークシート/ユーザーフォーム内にPublicで関数を定義すれば呼べるのでその場合ArrayMapのほぼ上位互換として使用できます。
それらの場所に定義する場合は標準モジュールと名前が被っていても問題ないので関数そのままコピペでOKです
なお、Sumなどのワークシート関数はApplication.WorkSheetFunctionのメソッドという扱いなのでそのまま呼び出せます
Function ArrayMap2(obj, procName, arr, ParamArray args())
obj:[Object] COMオブジェクトやクラスのインスタンス、ワークシートなどの対象のメソッド/プロパティが定義してあるオブジェクト
procName:[String] メソッド/プロパティの名前を文字列で指定
指定するメソッド/プロパティは第一引数に配列の各要素を受け取る必要がある
ユーザー定義関数(Sub/Function)もクラスモジュールかワークシート、ユーザーフォーム内に定義すれば呼び出し可能
arr:[Variant][Array] 対象の配列
args: [可変長引数][Variant] procNameで指定したメソッド/プロパティの第二引数以降を指定(省略可、最大10個まで)
戻り値:[Variant()] メソッド/プロパティの結果を適用した配列
使用例1(fsoで配列内のフォルダ存在チェック)
Dim fso As Object
Dim result1(), result2()
' 直接インスタンスを生成して引数に渡す
result1 = ArrayMap2(CreateObject("Scripting.FileSystemObject"), "FolderExists", Array("C:\Windows", "C:\hoge"))
Debug.Print Join(result1, ", ") ' [True, False]
' 変数にインスタンスを代入して引数に渡す
Set fso = CreateObject("Scripting.FileSystemObject")
result2 = ArrayMap2(fso, "FolderExists", Array("C:\Windows", "C:\hoge"))
Debug.Print Join(result2, ", ") ' [True, False]
使用例2(クラスモジュール内に記述した関数を呼び出す)
'-----MyTypeNameをクラスモジュール(Class1)に定義----
Function MyTypeName(ByVal value As Variant) As String
MyTypeName = TypeName(value)
End Function
'-----↓標準モジュールに定義-----
Sub test()
Dim arr, result1, result2
Dim objCls1 As Object
arr = Array(1, "a", Nothing, Array(1, 2), True)
' その場でインスタンスを生成する例
result1 = ArrayMap2(New Class1, "MyTypeName", arr) ' [Integer, String, Nothing, Variant(), Boolean]
Debug.Print Join(result1, ", ")
' 変数に代入したインスタンスを渡す例
Set objCls1 = New Class1
result2 = ArrayMap2(objCls1, "MyTypeName", arr) ' [Integer, String, Nothing, Variant(), Boolean]
Debug.Print Join(result2, ", ")
End Sub
使用例2(ワークシート内に記述した関数を呼び出す)
'-----MyTypeNameをワークシート内(Sheet1)に定義----
Function MyTypeName(ByVal value As Variant) As String
MyTypeName = TypeName(value)
End Function
'-----↓標準モジュールに定義-----
Sub test()
Dim arr, result1, result2
Dim ws As Worksheet
' シート名を直接指定
arr = Array(1, "a", Nothing, Array(1, 2), True)
result1 = ArrayMap2(Sheet1, "MyTypeName", arr) ' [Integer, String, Nothing, Variant(), Boolean]
Debug.Print Join(result1, ", ")
' wsオブジェクトを指定
Set ws = ThisWorkbook.Sheets("Sheet1")
result2 = ArrayMap2(ws, "MyTypeName", arr) ' [Integer, String, Nothing, Variant(), Boolean]
Debug.Print Join(result2, ", ")
End Sub
使用例3(WorksheetFunctionを呼び出し)
Dim arr, result
Dim ws As Worksheet
Set ws = ThisWorkbook.ActiveSheet
ws.Range("A1").value = 1
ws.Range("A2").value = 2
ws.Range("A3").value = 3
ws.Range("B1").value = 10
ws.Range("B2").value = 20
ws.Range("B3").value = 30
ws.Range("C1").value = 100
ws.Range("C2").value = 200
ws.Range("C3").value = 300
arr = Array(ws.Range("A1:A3"), ws.Range("B1:B3"), ws.Range("C1:C3"))
result = ArrayMap2(WorksheetFunction, "Sum", arr) ' [6, 60, 600]
Debug.Print Join(result, ", ")
・オブジェクトを代入した配列の各要素にメソッド/プロパティの結果を適用
Function ArrayMap3(procName, arr, ParamArray args())
procName:[String] メソッド/プロパティの名前を文字列で指定
arr:[Variant][Array] 対象の配列、オブジェクト以外が代入されているとエラーになる
args: [可変長引数][Variant] procNameで指定したメソッド/プロパティの引数を第一引数から指定(省略可、最大10個まで)
戻り値:[Variant()] 配列の各要素にメソッド/プロパティの結果を適用した配列
使用例1(全シートの名前を取得)
Dim result
result = ArrayMap3("Name", CollectionToArray(ThisWorkbook.Sheets)) ' [Sheet1, Sheet2, Sheet3, Sheet4]
Debug.Print Join(result, ", ")
使用例2(ArrayMap2と組み合わせてファイルパス一覧からファイルサイズを取得)
Dim arr, arr2, result
arr = Array("C:\Windows\notepad.exe", "C:\Windows\regedit.exe", "C:\Windows\winhlp32.exe")
' ファイルパスからfsoのFileオブジェクトを取得
arr2 = ArrayMap2(CreateObject("Scripting.FileSystemObject"), "GetFile", arr)
' 各Fileオブジェクトにsizeメソッドを使用した結果を取得
result = ArrayMap3("size", arr2) ' [352256, 397312, 12288]
Debug.Print Join(result, ", ")
・配列が初期化済か判定
配列型として宣言のみ行いReDimしてない配列かReDim済かを判別するための関数です
Function IsInitializedArray(arr)
配列の未初期化/初期化済を判定
arr:[Variant][Array] 判定対象配列
戻り値:[Boolean] 判定結果 未初期化 -> False, 初期化済 -> True
配列でないものを渡すとエラー
使用例
Dim arr1()
Dim arr2()
Dim arr3()
Dim arr4
ReDim arr2(0 To 10)
arr3 = Array()
arr4 = Array(1, 2, 3)
Debug.Print IsInitializedArray(arr1) ' False
Debug.Print IsInitializedArray(arr2) ' True
Debug.Print IsInitializedArray(arr3) ' True
Debug.Print IsInitializedArray(arr4) ' True
・配列同士を比較
Function ArrayEquals(arr1, arr2, ignoreIdxDiff=True)
arr1, arr2:[Variant][Array] 比較する配列
ignoreIdxDiff:[Boolean] 開始インデックスの違いを無視して比較するかどうか
戻り値:[Boolean] 判定結果
※数値以外は厳密な型比較を行う
※ジャグ配列には未対応、オブジェクトは参照先アドレス一致の場合同じ値と判定
使用例
Dim arr1()
Dim arr2()
' 未初期化配列同士
Debug.Print ArrayEquals(arr1, arr2) ' True
' 要素0の配列と未初期化配列
Debug.Print ArrayEquals(Array(), arr2) ' False
' 未初期化配列と要素0の配列
Debug.Print ArrayEquals(arr1, Array()) ' False
' 要素0の配列同士
Debug.Print ArrayEquals(Array(), Array()) 'True
' 同じ要素数で開始インデックス0と開始インデックス1の配列の比較(ignoreIdxDiff=True)
Debug.Print ArrayEquals(Array(1, 2, 3), OffsetArray(Array(1, 2, 3), 1)) ' True
' 同じ要素数で開始インデックス0と開始インデックス1の配列の比較(ignoreIdxDiff=False)
Debug.Print ArrayEquals(Array(1, 2, 3), OffsetArray(Array(1, 2, 3), 1), False) ' False
' 途中まで要素が一致している配列
Debug.Print ArrayEquals(Array(1, 2, 3), Array(1, 2, 3, 4)) ' False
・配列の中の特定の値を別の値に置換
ADOやDAOでExcel/Accessのデータを取得すると何もない箇所はNullになりますがNullのままだと都合が悪い場合、これで空文字やEmptyに置換できます
Sub ReplaceValueInArray(arr, value, newValue)
arr:[Variant][Array] 対象の配列(ByRef)
value:[Variant] 置換対象の値
newValue:[Variant] 置換後の値
※置換するかの判定は数値以外は厳密な型比較を行う
※置換対象要素が配列の場合は未対応、オブジェクトは参照先アドレス一致の場合同じ値と判定
使用例
Dim arr()
arr = Array(Null, "A", "B", "C", Null)
Call ReplaceValueInArray(arr, Null, Empty) ' [Empty, "A", "B", "C", Empty]
・範囲内の配列の中にない数字を返す
ArrayIndexOf2で取得した要素をこの関数の引数にして取得した配列をArrayRemoveIndexの削除インデックスとして渡すと指定の値以外を削除したりできます
Function GetMissingNumbers(numberList, startNum, endNum)
numberList:[Variant][Array/Collection] 数値の配列/コレクション
startNum:[Long] 範囲開始数値
endNum:[Long] 範囲終了数値
戻り値:[Variant()] numberListの中にない整数の配列
※数値以外のものがnumberListに入っているとエラーになる
使用例
Dim arr(), result()
arr = Array(1, 2, 5)
result = GetMissingNumbers(arr, 0, 7) '[0, 3, 4, 6, 7]
Debug.Print Join(result, ", ")
使用例2(他の関数と組み合わせて二次元配列をフィルターにかける)
Function IsgreaterThanOrEqualTo(ByVal num1 As Long, ByVal num2 As Long) As Boolean
IsgreaterThanOrEqualTo = (num1 >= num2)
End Function
Sub test()
Dim arr, arr2d, temp1, temp2, indexes1, indexes2, result1, result2
arr = Array( _
Array(3, "A", "B", "C", "D"), _
Array(4, "E", "F", "G", "H"), _
Array(2, "I", "J", "K", "L"), _
Array(5, "M", "N", "O", "P"))
' 二次元配列を定義(ジャグ配列から変換)
arr2d = ArrayJaggedTo2D(arr)
' 二次元配列からキーにする配列を一次元配列として取り出す、インデックス0の列を取り出し
temp1 = Extract2DArrayCol(arr2d, 0) ' [3, 4, 2, 5]
' ArrayMapでIsgreaterThanOrEqualToの結果を適用し4以上の数値はTrue、それ以外Falseに
temp2 = ArrayMap("IsgreaterThanOrEqualTo", temp1, 4) '[False, True, False, True]
' Trueになっている数値(要素が4以上のインデックス)を探す
indexes1 = ArrayIndexOf2(temp2, Array(True)) ' [1, 3]
' その逆(4以上でないもの)のインデックスをGetMissingNumbersで取得
indexes2 = GetMissingNumbers(indexes1, LBound(temp2), UBound(temp2)) ' [0, 2]
' 4以上になっている箇所の行は消し、4未満の箇所の行は残る
result1 = Array2DRemoveRowIndex(arr2d, indexes1) ' [[3, "A", "B", "C", "D"], [2, "I", "J", "K", "L"]]
' その逆で4未満になっている行が消え、4以上になっている行が残る
result2 = Array2DRemoveRowIndex(arr2d, indexes2) ' [[4, "E", "F", "G", "H"], [5, "M", "N", "O", "P"]]
End Sub
・配列の重複した要素のインデックスを取得
Function ArrayDuplicateIndexes(arr, caseSensitive=True)
arr:[Variant][Array] 対象の配列
caseSensitive:[Boolean] 大文字と小文字を区別するか Trueで区別する、Falseで区別しない デフォルトTrue
戻り値:[Variant()] 重複要素のインデックス番号一覧の配列、重複す要素がない場合空の配列
※caseSensitive=Trueの場合内部でUnicodeに変換するため速度は落ちる
※数値以外は厳密な型比較を行う
※ジャグ配列には未対応、オブジェクトは参照先アドレス一致の場合同じ値と判定
使用例
Dim result
result = ArrayDuplicateIndexes(Array(1, 1, 3, 1, 3, 2, 4)) ' [1, 3, 4]
Debug.Print Join(result, ", ")
使用例2(二次元配列の一部が重複した箇所のインデックスを削除)
Function JoinSpecifiedIndexes(ByVal arr As Variant, ByVal indexes As Variant) As String
Dim index As Variant
Dim result As String: result = ""
For Each index In indexes
result = result & "[" & index & "]" & arr(index)
Next
JoinSpecifiedIndexes = result
End Function
Sub test()
Dim arr, arr2d, temp1, temp2, indexes, result
arr = Array( _
Array(3, "A", "B", "C", "D"), _
Array(4, "A", "B", "G", "H"), _
Array(2, "A", "B", "K", "L"), _
Array(5, "M", "N", "O", "P"))
arr2d = ArrayJaggedTo2D(arr)
' ジャグ配列に変換
temp1 = Array2DToJagged(arr2d)
' インデックス1, 2の要素だけ取り出して要素を結合
temp2 = ArrayMap("JoinSpecifiedIndexes", temp1, Array(1, 2)) ' ["[1]A[2]B", "[1]A[2]B", "[1]A[2]B", "[1]M[2]N"]
' 結合文字列の配列から重複要素のインデックスを取得
indexes = ArrayDuplicateIndexes(temp2) ' [1, 2]
' 重複要素のインデックスを削除
result = Array2DRemoveRowIndex(arr2d, indexes) ' [[3, "A", "B", "C", "D"], [5, "M", "N", "O", "P"]]
End Sub
・配列の重複した要素を削除
Function ArrayRemoveDuplicates(arr, caseSensitive=True)
arr:[Variant][Array] 重複削除対象の配列
caseSensitive:[Boolean] 大文字と小文字を区別するか Trueで区別する、Falseで区別しない デフォルトTrue
戻り値:[Variant()] 重複削除後の配列
※caseSensitive=Trueの場合内部でUnicodeに変換するため速度は落ちる
※数値以外は厳密な型比較を行う
※ジャグ配列には未対応、オブジェクトは参照先アドレス一致の場合同じ値と判定
使用例
Dim arr, result1, result2
arr = Array("Empty", "", 0, 1, "0", 2, 3, 1, "C", "c", "apple", "0", "Apple")
result1 = ArrayRemoveDuplicates(arr) '[Empty, "", 0, 1, "0", 2, 3, "C", "c", "apple". "Apple"]
result2 = ArrayRemoveDuplicates(arr, False) '[Empty, "", 0, 1, "0", 2, 3, "C", "apple"]
・配列をインデックスでフィルター
指定のインデックスの要素のみを抽出した配列を作成します
条件合致の値を絞るにはArrayMap+ArrayIndexOf2との相性が良いです
Function FilterArrayByIndexes(ByVal arr As Variant, ByVal indexes As Variant)
arr:[Variant][Array] 対象の配列
indexes:[Variant][Array/Collection] 抽出したいインデックスの一覧、インデックスはこの一覧で指定した順に取り出される
戻り値:[Variant()] フィルター後の配列
使用例
Dim arr, result
arr = Array("A", "B", "C", "D")
result = FilterArrayByIndexes(arr, Array(2, 3, 0))
Debug.Print Join(result, ", ") ' ["C","D","A"]
・指定の値が含まれているかチェック(配列・コレクション・辞書)
Function ContainsValue(itemList, value)
itemList:[Variant][Array/Collection/Dictionary] チェック対象の配列/コレクション/Dictionary
value:[Variant] 検索対象の値
戻り値:[Boolean] 含まれている場合はTrue、含まれていない場合はFalse
※数値以外は厳密な型比較を行う
※配列内の配列の検索には未対応、オブジェクトは参照先アドレス一致の場合同じ値と判定
使用例
Debug.Print ContainsValue(Array(1, 2, 3), 1) ' True
Debug.Print ContainsValue(Array("1", 2, 3), 1) ' False
Debug.Print ContainsValue(Array("", 0, 3), Empty) ' False
Pythonでは以下のコードに対応します
print(1 in [1, 2, 3]) # True
・指定の値の個数を数える(配列・コレクション・辞書)
Function CountValues(itemList, value)
itemList:[Variant][Array/Collection/Dictionary] チェック対象の配列/コレクション/Dictionary
value:[Variant] 検索対象の値
戻り値:[Long] 含まれている個数
※数値以外は厳密な型比較を行う
※配列内の配列の検索には未対応、オブジェクトは参照先アドレス一致の場合同じ値と判定
使用例
Debug.Print CountValues(Array(1, 2, 3, 1), 1) ' 2
Debug.Print CountValues(Array("1", 2, 3, 1), 1) ' 1
Debug.Print CountValues(Array("", 0, 3), Empty) ' 0
・値がイテラブル(For Eachで回せるデータ)かどうか判定
配列、コレクション、Dictionary、.NETのArrayListなどにTrueを返します
Function IsIterable(value)
value:[Variant] この値がイテラブルかどうか判定する
戻り値:[Boolean] イテラブルならTrue
使用例
Dim coll As New Collection
coll.Add 1
Debug.Print IsIterable(Array(1, 2, 3)) ' True
Debug.Print IsIterable(Array()) ' True
Debug.Print IsIterable(coll) ' True
Debug.Print IsIterable(0) ' False
Debug.Print IsIterable(Nothing) ' False
・イテラブルの要素数を数える
データ型に縛られないですが普通に.CountメソッドやArrayLengthを使うより遅くなります
Function IterableCount(iterable)
iterable:[Variant] カウント対象のイテラブル
戻り値:[Boolean] イテラブルの要素数
使用例
Dim coll As New Collection
coll.Add 1
Debug.Print IterableCount(Array(1, 2, 3)) ' 3
Debug.Print IterableCount(Array()) ' 0
Debug.Print IterableCount(coll) ' 1
・指定要素のコレクションを生成
簡単にいえば、Array関数のコレクション版です
引数なしで実行した場合、要素数0のコレクションが生成されます
Function CreateColl(ParamArray items())
items:[可変長引数][Variant] コレクションの各要素
戻り値:[Collection] 生成されたコレクション
使用例
Dim coll As Collection
Set coll = CreateColl(1, 2, 3) '[1, 2, 3]
・配列をコレクションに変換
Function ArrayToCollection(arr)
arr:[Variant][Array] 変換する配列
戻り値:[Collection] 変換されたコレクション
使用例
Dim arr
Dim coll As Collection
arr = Array(1, 2, 3)
Set coll = ArrayToCollection(arr) '[1, 2, 3]
・コレクションを配列に変換
コレクションはインデックス指定での要素取り出しがとても遅いので、インデックス指定したい場合は一旦この関数で配列に変換したほうが高速です
Function CollectionToArray(coll, isStartIdx1=False)
coll:[Variant][Collection/その他コレクション型オブジェクト]
変換するコレクション、ThisWorkbook.Sheets, Application.Workbooks, Application.RecentFilesなどの変換も対応
isStartIdx1:[Boolean] Trueの場合、開始インデックスが1の配列を作成(コレクションと番号を合わせる)、デフォルトはFalse(0開始)
戻り値:[Variant()] 変換された配列
※要素数0のコレクションを変換した場合、Array()で作成できる要素数0の配列を返す
使用例
Dim coll As New Collection
Dim arr() As Variant
coll.Add 1
coll.Add 2
coll.Add 3
arr = CollectionToArray(coll) '[1, 2, 3]
Debug.Print LBound(arr) & ", " & UBound(arr) ' 0, 2
arr = CollectionToArray(coll, True) '[1, 2, 3]
Debug.Print LBound(arr) & ", " & UBound(arr) ' 1, 3
・ネストされたコレクションを配列に変換
VBA-JSONのジャグ配列はコレクションに変換されますが、それを配列に戻すために使います
Function NestedCollectionToArray(coll, isStartIdx1=False)
coll:[Variant][Collection/その他コレクション型オブジェクト] 変換するコレクション
isStartIdx1:[Boolean] Trueの場合、開始インデックスが1の配列を作成(ネストされた配列を含める)、デフォルトはFalse(0開始)
戻り値:[Variant()] 変換された配列
※要素数0のコレクションを変換した場合、Array()で作成できる要素数0の配列に変換される
使用例
Dim coll As New Collection
Dim coll2 As New Collection
Dim arr() As Variant
coll2.Add 1
coll2.Add 2
coll.Add 0
coll.Add coll2
Debug.Print TypeName(coll) ' Collection
Debug.Print TypeName(coll(1)) ' Integer
Debug.Print TypeName(coll(2)) ' Collection
arr = NestedCollectionToArray(coll)
Debug.Print TypeName(arr) ' Variant()
Debug.Print TypeName(arr(0)) ' Integer
Debug.Print TypeName(arr(1)) ' Variant()
・コレクションのキーの存在チェック
Dictionaryの.Existsメソッドに相当します
Function CollContainsKey(coll, key)
coll:[Collection] チェック対象のコレクション
key:[String] チェック対象のキー
戻り値:[Boolean] キーが含まれていればTrue, 含まれていなければFalse
使用例
Dim coll As New Collection
coll.Add "", "key1"
coll.Add "", "key2"
Debug.Print CollContainsKey(coll, "key1") ' True
Debug.Print CollContainsKey(coll, "key2") ' True
Debug.Print CollContainsKey(coll, "key3") ' False
・コレクションを反転
Function ReverseCollection(coll)
coll:[Collection] 反転対象のコレクション
戻り値:[Collection] 反転させたコレクション
使用例
Dim coll As New Collection
Dim result As Collection
coll.Add 1
coll.Add 2
coll.Add 3
Set result = ReverseCollection(coll) ' [3, 2, 1]
・コレクションのソート
Function QuickSortCollection(coll, reverse=False, strSort=False, ignoreCase=True)
coll:[Collection] ソート対象のコレクション
reverse:[Boolean] Trueで降順ソートする
strSort:[Boolean] Trueで文字列基準ソート、Falseで数値基準ソート
ignoreCase:[Boolean] TrueでstrSort:=Trueの場合に大文字、小文字を区別しないで比較する
戻り値:[Collection] ソート後のコレクション
使用例
Dim coll As New Collection
Dim result As Collection
coll.Add 1
coll.Add 3
coll.Add 2
Set result = QuickSortCollection(coll) ' [1, 2, 3]
・コレクションを結合(元のコレクションを変更)
ここに記載のExtendArrayのコレクション版です
コレクション以外でも.Addメソッドがあるコンテナ型のデータ型なら使用できます(.NETのArrayListなど)
Sub ExtendCollection(originalColl, additionalColl)
originalColl(ByRef):[Variant][Collection/その他] 変更対象のコレクション
additionalColl:[Variant][Collection/その他] 結合する配列
使用例
Dim coll As New Collection
Dim coll2 As New Collection
coll.Add 1
coll.Add 2
coll.Add 3
coll2.Add 4
coll2.Add 5
coll2.Add 6
Call ExtendCollection(coll, coll2) ' [1, 2, 3, 4, 5, 6]
・コレクション同士を結合し、新しいコレクションを作成
ここに記載のConcatArraysのコレクション版です
Function ConcatCollections(ParamArray collections())
collections:[可変長引数][Collection] 結合対象のコレクションを順番に指定
戻り値:[Collection] 結合後のコレクション
使用例
Dim coll1 As New Collection
Dim coll2 As New Collection
Dim result As Collection
coll1.Add 1
coll1.Add 2
coll1.Add 3
coll2.Add 4
coll2.Add 5
coll2.Add 6
Set result = ConcatCollections(coll1, coll2) ' [1, 2, 3, 4, 5, 6]
・コレクション同士を結合(結合対象を配列かコレクションで指定)
ConcatArrays2のコレクション版です
Function ConcatCollections2(collections)
collections:[Variant][Array/Collection] 結合対象のコレクションを配列またはコレクションで指定
戻り値:[Collection] 結合後のコレクション
使用例
Dim coll1 As New Collection
Dim coll2 As New Collection
Dim arr() As Variant
Dim result As Collection
coll1.Add 1
coll1.Add 2
coll1.Add 3
coll2.Add 4
coll2.Add 5
coll2.Add 6
arr = Array(coll1, coll2)
Set result = ConcatCollections2(arr) ' [1, 2, 3, 4, 5, 6]
・コレクションの指定要素を削除
ここに記載のArrayRemoveValueのコレクション版です
Function CollRemoveValue(coll, value)
coll:[Collection] 対象のコレクション
value:[Variant] 削除する要素
戻り値:[Collection] 要素削除後のコレクション
※ 削除対象の値が1つも入っていない場合はエラーになる
※ 削除判定のさい数値以外は厳密な型比較を行う
※ 配列の判定には未対応、オブジェクトは参照先アドレス一致の場合同じ値と判定
使用例
Dim coll As New Collection
Dim result As Collection
coll.Add 1
coll.Add 2
coll.Add 3
coll.Add 1
Set result = CollRemoveValue(coll, 1) '[2, 3]
・コレクションの重複した要素を削除
ここに記載のArrayRemoveDuplicatesのコレクション版です
Function CollRemoveDuplicates(coll, caseSensitive=True)
coll:[Collection] 重複削除対象のコレクション
caseSensitive:[Boolean] 大文字と小文字を区別するか Trueで区別する、Falseで区別しない デフォルトTrue
戻り値:[Collection] 重複削除後のコレクション
※ caseSensitive=Trueの場合内部でUnicodeに変換するため速度は落ちる
※ 削除判定のさい数値以外は厳密な型比較を行う
※ 配列の判定には未対応、オブジェクトは参照先アドレス一致の場合同じ値と判定
使用例
Dim coll As New Collection
Dim result As Collection
coll.Add 1
coll.Add 1
coll.Add 2
coll.Add 3
coll.Add 1
coll.Add "1"
Set result = CollRemoveDuplicates(coll) ' [1, 2, 3, "1"]
・二次元配列の反転
縦(行)反転
Function Reverse2DArrayV(arr2d)
横(列)反転
Function Reverse2DArrayH(arr2d)
arr2d:[Variant][Array(2D)] 対象の二次元配列
戻り値:[Variant()][Array(2D)] 反転後の二次元配列
使用例
Dim arr, arr2d, result1, result2
arr = Array( _
Array(1, "A", "B", "C", "D"), _
Array(2, "E", "F", "G", "H"), _
Array(3, "I", "J", "K", "L"))
arr2d = ArrayJaggedTo2D(arr)
result1 = Reverse2DArrayV(arr2d) ' [[3,"I","J","K","L"],[2,"E","F","G","H"],[1,"A","B","C","D"]]
result2 = Reverse2DArrayH(arr2d) ' [["D","C","B","A",1],["H","G","F","E",2],["L","K","J","I",3]]
・二次元配列の行列入れ替え
WorksheetFunction.Transposeは行数制限があるのと入れ替え後の配列の開始インデックスが1になってしまうのでちょっと使い勝手が悪いです
この関数はそれを解消しています、速度もこちらのほうが若干速いです
Function Transpose2DArray(arr2d)
arr2d:[Variant][Array(2D)] 対象の二次元配列
戻り値:[Variant()][Array(2D)] 行列入替後の二次元配列
※ 開始インデックスは元の配列のものを引き継ぐ
・ジャグ配列の行列入れ替え
ArrayMapと組み合わせて条件判定させたいときによく使います
Function TransposeJaggedArray(arr)
arr:[Variant][Array] 対象のジャグ配列
戻り値:[Variant()][Array] 行列入替後のジャグ配列
※ すべての内部配列の開始・終了インデックスが一致していないと実行時エラー
実行イメージ:
入替前: [[1, 2, 3, 4], [5, 6, 7, 8], [9, 10, 11, 12]]
入替後: [[1, 5, 9], [2, 6, 10], [3, 7, 11], [4, 8, 12]]
・一次元配列を二次元配列に変換
主に一次元配列をセルに貼り付けたいときに使います
縦方向の二次元配列を作成(n行1列の二次元配列を作成)
Function Array1DTo2DV(arr1d)
横方向の二次元配列を作成(1行n列の二次元配列を作成)
Function Array1DTo2DH(arr1d)
arr1d:[Variant][Array] 変換対象の一次元配列
戻り値:[Variant()][Array(2D)] 変換後の二次元配列
・二次元配列同士を結合
縦方向に結合
Function Concat2DArraysV(arraysToConcat, newFirstRow=0, newFirstCol=0)
横方向に結合
Function Concat2DArraysH(arraysToConcat, newFirstRow=0, newFirstCol=0)
arraysToConcat:[Variant][Array/Collection] 結合したい二次元配列の一覧を配列またはコレクションで指定
newFirstRow:[Long] 作成される二次元配列の開始行番号
newFirstCol:[Long] 作成される二次元配列の開始列番号
戻り値:[Variant()][Array(2D)] 結合された二次元配列
・二次元配列の開始インデックスを変更
Function Offset2DArray(arr2d, newFirstRow, newFirstCol)
arr2d:[Variant][Array(2D)] 対象の二次元配列
newFirstRow:[Long] 変更先の開始行インデックス
newFirstCol:[Long] 変更先の開始列インデックス
戻り値:[Variant()][Array(2D)] 開始インデックス変更後の二次元配列
・二次元配列をスライス
Function Slice2DArray(arr2d, startRow, endRow, startCol, endCol)
arr2d:[Variant][Array(2D)] 対象の二次元配列
startRow:[Long] スライス開始行のインデックス番号
endRow:[Long] スライス終了行のインデックス番号
startCol:[Long] スライス開始列のインデックス番号
endCol:[Long] スライス終了列のインデックス番号
戻り値:[Variant()][Array(2D)] スライス後の二次元配列
※配列の開始インデックスは元の配列のものを維持する
※指定したインデックス自体もスライス範囲に含まれる
・二次元配列をリサイズ
ReDim Preserveでは一番上の次元しか変更できないのですがこの関数を使えば変更可能です
Function Resize2DArray(arr2d, lowerRow, upperRow, lowerCol, upperCol)
arr2d:[Variant][Array(2D)] 対象の二次元配列
lowerRow:[Long] リサイズ後の開始行のインデックス番号
upperRow:[Long] リサイズ後の終了行のインデックス番号
lowerCol:[Long] リサイズ後の開始列のインデックス番号
upperCol:[Long] リサイズ後の終了列のインデックス番号
戻り値:[Variant()][Array(2D)] リサイズ後の二次元配列
※既存の要素のインデックスはリサイズ後も変わらない
・二次元配列の指定列、行を一次元配列として抽出
列を指定して抽出
Function Extract2DArrayCol(arr2d, colIdx)
行を指定して抽出
Function Extract2DArrayRow(arr2d, rowIdx)
arr2d:[Variant][Array(2D)] (ByRef) 抽出対象の二次元配列
colIdx/rowIdx:[Long] 抽出する列/行のインデックス
戻り値:[Variant()] 抽出した一次元配列
使用例
Dim arr, arr2d, result1, result2, result3, result4
arr = Array( _
Array(3, "A", "B", "C", "D"), _
Array(4, "E", "F", "G", "H"), _
Array(2, "I", "J", "K", "L"), _
Array(5, "M", "N", "O", "P"))
arr2d = ArrayJaggedTo2D(arr)
result1 = Extract2DArrayCol(arr2d, 0) ' [3, 4, 2, 5]
result2 = Extract2DArrayCol(arr2d, 1) ' ["A", "E", "I", "M"]
result3 = Extract2DArrayRow(arr2d, 0) ' [3, "A", "B", "C", "D"]
result4 = Extract2DArrayRow(arr2d, 1) ' [4, "E", "F", "G", "H"]
Debug.Print Join(result1, ", ")
Debug.Print Join(result2, ", ")
Debug.Print Join(result3, ", ")
Debug.Print Join(result4, ", ")
・ジャグ配列を二次元配列に変換
Function ArrayJaggedTo2D(jaggedArr, firstRow=0, firstCol=0)
jaggedArr:[Variant][Array] 変換対象のジャグ配列
firstRow:[Long] 変換後の二次元配列の開始行のインデックス
firstCol:[Long] 変換後の二次元配列の開始列のインデックス
戻り値:[Variant()][Array(2D)] 変換後の二次元配列
※ジャグ配列の開始インデックスは変換後の二次元配列には影響せず、相対的な位置のみで変換される
・二次元配列をジャグ配列に変換
Function Array2DToJagged(arr2d)
arr2d:[Variant][Array(2D)] 変換対象の二次元配列
戻り値:[Variant()] 変換後のジャグ配列
※変換後のジャグ配列の開始インデックスは二次元配列のものを元に決まる
・一次元配列を二次元配列の特定位置に貼り付ける
縦方向に貼り付ける
Sub Paste1DArrayTo2DArrayV(arr2d, arr1d, startRow, startCol)
横方向に貼り付ける
Sub Paste1DArrayTo2DArrayH(arr2d, arr1d, startRow, startCol)
arr2d(ByRef):[Variant][Array(2D)] 貼り付け対象の二次元配列(直接変更を加える)
arr1d:[Variant][Array] 貼り付ける一次元配列
startRow:[Long] 貼り付け開始の行番号
startCol:[Long] 貼り付け開始の列番号
使用例
Dim arr, arr2d
arr = Array( _
Array(3, "A", "B", "C", "D"), _
Array(4, "E", "F", "G", "H"), _
Array(2, "I", "J", "K", "L"))
arr2d = ArrayJaggedTo2D(arr)
Call Paste1DArrayTo2DArrayV(arr2d, Array(1, 5), 1, 0)
' [[3, "A", "B", "C", "D"], [1, "E", "F", "G", "H"], [5, "I", "J", "K", "L"]]
Call Paste1DArrayTo2DArrayH(arr2d, Array(1, 2, 3, 4), 0, 0)
' [[1, 2, 3, 4, "D"], [1, "E", "F", "G", "H"], [5, "I", "J", "K", "L"]]
・二次元配列のソート
Function MergeSort2DArray(arr2d, keyCol, reverse=False, strSort=False, ignoreCase=True, header=False, sortFrom=Null, sortTo=Null)
マージソートで二次元配列のソートを行う(高速安定ソート)
arr2d:[Variant][Array(2D)] 対象の二次元配列
keyCol[Variant][Array/Long/Null]
ソート基準の列のインデックスをNull、数字そのままか配列を指定
Nullの場合自動的に最小列のインデックス
配列を指定した場合配列の最初のほうの要素ほどソートの優先度が高い
例えばArray(1, 2, 3)を指定した場合3, 2, 1基準の順番でソートが行われる
オブジェクトなど、比較できないものが入っている列を指定するとエラーになる
reverse:[Boolean] Trueで降順ソートする
strSort:[Boolean] Trueで文字列基準ソート、Falseで数値基準ソート
ignoreCase:[Boolean] TrueでstrSort:=Trueの場合に大文字、小文字を区別しないで比較する
header:[Boolean] Trueで1番最初の行をソート対象に入れない
sortFrom:[Variant][Null/Long] ソート対象行の開始インデックス, Null/数字、Null指定時は最小インデックス、数字指定時はheader指定を無視
sortTo:[Variant][Null/Long] ソート対象行の終了インデックス、Null指定時は最大インデックス
戻り値:[Variant()][Array(2D)] ソート後の配列
・二次元配列の指定行/列を削除
指定行を削除
Function Array2DRemoveRowIndex(arr2d, targetIndex)
指定列を削除
Function Array2DRemoveColIndex(arr2d, targetIndex)
arr2d: 対象の二次元配列
targetIndex:[Variant][Long/Array/Collection] 削除対象の行/列のインデックスを数字または数字の配列/コレクションで指定
戻り値:[Variant()][Array(2D)] 行/列削除後の二次元配列
・二次元配列をインデックスでフィルター
FilterArrayByIndexesの二次元配列版です
行番号でフィルター
Function Filter2DArrayByRowIndexes(ByVal arr2d As Variant, ByVal indexes As Variant)
列番号でフィルター
Function Filter2DArrayByColIndexes(ByVal arr2d As Variant, ByVal indexes As Variant)
arr2d:[Variant][Array(2D)] 対象の二次元配列
indexes:[Variant][Array/Collection] 抽出したいインデックスの一覧、インデックスはこの一覧で指定した順に取り出される
戻り値:[Variant()][Array(2D)] フィルター後の二次元配列
実行イメージ
行番号フィルター
arr2d: [[1, 2], [3, 4], [5, 6], [7, 8]], indexes: [1, 3] -> [[3, 4], [7, 8]]
列番号フィルター
arr2d: [[1, 2, 3, 4], [5, 6, 7, 8]], indexes: [1, 3] -> [[2, 4], [6, 8]]
・二次元配列の中の特定の値を別の値に置換
ReplaceValueInArrayの二次元配列版です
Sub ReplaceValueIn2DArray(arr2d, value, newValue)
arr2d:[Variant][Array(2D)] 対象の二次元配列(ByRef)
value:[Variant] 置換対象の値
newValue:[Variant] 置換後の値
※置換するかの判定は数値以外は厳密な型比較を行う
※置換対象要素が配列の場合は未対応、オブジェクトは参照先アドレス一致の場合同じ値と判定
・二次元配列をセルに貼り付け
ループで回さなくてもこの関数で一瞬で二次元配列をExcelシートに貼り付け可能です
当然ですがExcel VBA専用です、Access VBAなど他のVBAでこの関数の定義がエラーにならないようrngCellはObject型にしています
Sub Paste2DArrayToCell(ByVal rngCell As Object, ByVal arr2d As Variant)
rngCell:[Object][Range] 貼り付け先のセル
arr2d:[Variant][Array(2D)] 対象の二次元配列
使用例(アクティブシートのA1に貼り付ける例)
Dim arr, arr2d
arr = Array( _
Array(3, "A", "B", "C", "D"), _
Array(4, "E", "F", "G", "H"), _
Array(2, "I", "J", "K", "L"), _
Array(5, "M", "N", "O", "P"))
arr2d = ArrayJaggedTo2D(arr)
Call Paste2DArrayToCell(ActiveSheet.Cells(1, 1), arr2d)
・ソースコード全文
これを新規作成の標準モジュールに貼り付けて使用してください
他のモジュールと関数の名前が被る場合はクラスモジュールにしてカプセル化してもいいと思います
' ArrayUtil (Last Updated: 2026-3-25)
' https://qiita.com/ZeeZeX/items/931914c31a893f0742f8
' https://gist.github.com/ZeeZeX/ee8ecb4a8b80e84c2a0a88e0b4236a7c
' This software is released under the 0BSD License.
' Zero-Clause BSD
' Permission to use, copy, modify, and/or distribute this software for
' any purpose with or without fee is hereby granted.
' THE SOFTWARE IS PROVIDED “AS IS” AND THE AUTHOR DISCLAIMS ALL
' WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES
' OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE
' FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY
' DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN
' AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT
' OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
Option Explicit
Public Function ArrayLength(ByRef arr As Variant, Optional ByVal dimentionNum As Long = 1) As Long
' 配列の要素数を返す
' arr: 要素数を測る配列
' dimentionNum:
' 1 -> 一次元配列の長さまたは二次元配列の行数
' 2 -> 二次元配列の列数
' 未初期化配列に対しては0を返す
' 引数はByValだと配列のコピー分時間を取られるのでByRefで渡す
' ByRefである関係上、ParamArrayをそのまま渡すとエラーになるのでその場合CVarで囲む必要がある
Dim temp As Variant
If Not IsArray(arr) Then
Err.Raise Number:=13
Exit Function
End If
On Error GoTo Exception
temp = LBound(arr, dimentionNum)
On Error GoTo 0
ArrayLength = UBound(arr, dimentionNum) + (1 - LBound(arr, dimentionNum))
Exit Function
Exception:
' 未初期化配列の場合
If Err.Number <> 9 Then
Err.Raise Number:=Err.Number
Exit Function
End If
ArrayLength = 0
End Function
Public Function DynamicCompare(ByVal a As Variant, ByVal b As Variant, ByVal op As String, _
Optional ByVal shouldStrComp As Boolean = False, Optional ByVal ignoreCase As Boolean = True) As Boolean
' 演算子を文字列で指定して動的に比較を行う
' a, b: 比較したい値
' op: 演算子(">", ">=", "<", "<=", "=", "<>")を文字列で指定
' shouldStrComp: Trueで文字列比較モード、Falseで数値比較
' ignoreCase: shouldStrCompをTrueにした場合に有効、Trueで大文字、小文字を無視する
Dim result As Boolean
Dim compareMode As VbCompareMethod
If shouldStrComp Then
If ignoreCase Then
compareMode = vbTextCompare
Else
compareMode = vbBinaryCompare
End If
Select Case op
Case ">"
result = StrComp(a, b, compareMode) > 0
Case ">="
result = StrComp(a, b, compareMode) >= 0
Case "<"
result = StrComp(a, b, compareMode) < 0
Case "<="
result = StrComp(a, b, compareMode) <= 0
Case "="
result = StrComp(a, b, compareMode) = 0
Case "<>"
result = StrComp(a, b, compareMode) <> 0
Case Else
Err.Raise vbObjectError, , "Unknown operator: " & op
End Select
Else
Select Case op
Case ">"
result = (a > b)
Case ">="
result = (a >= b)
Case "<"
result = (a < b)
Case "<="
result = (a <= b)
Case "="
result = (a = b)
Case "<>"
result = (a <> b)
Case Else
Err.Raise vbObjectError, , "Unknown operator: " & op
End Select
End If
DynamicCompare = result
End Function
Public Sub QuickSortArray(ByRef arr As Variant, _
Optional ByVal reverse As Boolean = False, _
Optional ByVal strSort As Boolean = False, _
Optional ByVal ignoreCase As Boolean = True)
' 再帰処理を使い配列をクイックソート(不安定ソート)
' reverse:=Trueで降順ソートする
' strSort:=Trueで文字列基準ソート、Falseで数値基準ソート
' ignoreCase:=TrueでstrSort:=Trueの場合に大文字、小文字を区別しないで比較する
' 依存関数: ArrayLength, DynamicCompare
Dim LowerBound As Long, UpperBound As Long
If Not IsArray(arr) Then Err.Raise Number:=13
If ArrayLength(arr) > 0 Then
LowerBound = LBound(arr)
UpperBound = UBound(arr)
Call QuickSortArrayRecursive(arr, LowerBound, UpperBound, reverse, strSort, ignoreCase)
End If
End Sub
Private Sub QuickSortArrayRecursive(ByRef arr As Variant, _
ByVal minIndex As Long, _
ByVal maxIndex As Long, _
ByVal reverse As Boolean, _
ByVal strSort As Boolean, _
ByVal ignoreCase As Boolean)
Dim i As Long
Dim j As Long
Dim base As Variant
Dim swap As Variant
Dim op1 As String
Dim op2 As String
If reverse Then
op1 = ">"
op2 = "<"
Else
op1 = "<"
op2 = ">"
End If
base = arr(Int((minIndex + maxIndex) / 2))
i = minIndex
j = maxIndex
Do
Do While DynamicCompare(arr(i), base, op1, strSort, ignoreCase)
i = i + 1
Loop
Do While DynamicCompare(arr(j), base, op2, strSort, ignoreCase)
j = j - 1
Loop
If i >= j Then Exit Do
swap = arr(i)
arr(i) = arr(j)
arr(j) = swap
i = i + 1
j = j - 1
Loop
If (minIndex < i - 1) Then
Call QuickSortArrayRecursive(arr, minIndex, i - 1, reverse, strSort, ignoreCase)
End If
If (maxIndex > j + 1) Then
Call QuickSortArrayRecursive(arr, j + 1, maxIndex, reverse, strSort, ignoreCase)
End If
End Sub
Public Sub InsertionSortArray(ByRef arr As Variant, _
Optional ByVal reverse As Boolean = False, _
Optional ByVal strSort As Boolean = False, _
Optional ByVal ignoreCase As Boolean = True)
' 挿入ソートで配列をソート(安定ソート)、ソート速度は遅い
' 依存関数: DynamicCompare
If Not IsArray(arr) Then Err.Raise Number:=13
Dim minIndex As Long
Dim maxIndex As Long
Dim op As String
If reverse Then
op = "<"
Else
op = ">"
End If
minIndex = LBound(arr)
maxIndex = UBound(arr)
Dim i As Long, j As Long
Dim swap As Variant
For i = minIndex + 1 To maxIndex
swap = arr(i)
For j = i - 1 To minIndex Step -1
If DynamicCompare(arr(j), swap, op, strSort, ignoreCase) Then
arr(j + 1) = arr(j)
Else
Exit For
End If
Next
arr(j + 1) = swap
Next
End Sub
Public Sub InsertionSortJaggedArray(ByRef arr As Variant, _
Optional ByVal reverse As Boolean = False, _
Optional ByVal strSort As Boolean = False, _
Optional ByVal ignoreCase As Boolean = True)
' ネストされた配列の開始インデックスの要素の数値を基準に昇順で挿入ソートする
' 速度は遅いのでMergeSortJaggedArrayの使用を推奨
' 例: [[1, "A"], [3, "B"], [2, "C"]] -> [[1, "A"], [2, "C"], [3, "B"]]
' 同じ数値同士の並び順には影響を与えない
' 例: [[3, "C"], [3, "A"], [1, "A"], [3, "B"]] -> [[1, "A"], [3, "C"], [3, "A"], [3, "B"]]
' reverse:=Trueで降順ソートする
' strSort:=Trueで文字列基準ソート、Falseで数値基準ソート
' ignoreCase:=TrueでstrSort:=Trueの場合に大文字、小文字を区別しないで比較する
' 依存関数: DynamicCompare
If Not IsArray(arr) Then Err.Raise Number:=13
Dim minIndex As Long
Dim maxIndex As Long
Dim idxToRef1 As Long
Dim idxToRef2 As Long
Dim op As String
If reverse Then
op = "<"
Else
op = ">"
End If
minIndex = LBound(arr)
maxIndex = UBound(arr)
Dim i As Long, j As Long
Dim swap As Variant
For i = minIndex + 1 To maxIndex
swap = arr(i)
For j = i - 1 To minIndex Step -1
idxToRef1 = LBound(arr(j))
idxToRef2 = LBound(swap)
If DynamicCompare(arr(j)(idxToRef1), swap(idxToRef2), op, strSort, ignoreCase) Then
arr(j + 1) = arr(j)
Else
Exit For
End If
Next
arr(j + 1) = swap
Next
End Sub
Public Sub InsertionSortJaggedArray2(ByRef arr As Variant, _
ByVal keyIndex As Variant, _
Optional ByVal reverse As Boolean = False, _
Optional ByVal strSort As Boolean = False, _
Optional ByVal ignoreCase As Boolean = True, _
Optional ByVal sortFrom As Variant = Null, _
Optional ByVal sortTo As Variant = Null)
' InsertionSortJaggedArrayのソート基準インデックスとソート範囲を指定できるようにしたバージョン
' ネストされた配列の指定インデックスの要素の数値を基準に昇順で挿入ソートする、数字以外を指定した場合は文字コードで比較する
' reverse:=Trueで降順ソートする
' strSort:=Trueで文字列基準ソート、Falseで数値基準ソート
' ignoreCase:=TrueでstrSort:=Trueの場合に大文字、小文字を区別しないで比較する
' sortFrom, sortToでソート対象の範囲を指定可能、Nullの場合は配列の下限/上限
' 例1: keyIndex:=1, sortFrom:=Null, sortTo:=Null [[3, 2], [1, 1], [2, 3]] -> [[1, 1], [3, 2], [2, 3]]
' 例2: keyIndex:=0, sortFrom:=1, sortTo:=Null [[2, 3], [3, 1], [1, 2]] -> [[2, 3], [1, 2], [3, 1]]
' 例3: keyIndex:=1, sortFrom:=0, sortTo:=1 [[2, 3], [3, 1], [1, 2]] -> [[3, 1], [2, 3], [1, 2]]
' 同じ数値同士の並び順には影響を与えない
' 例4: keyIndex:=0, sortFrom:=Null, sortTo:=Null [[3, 3], [3, 1], [1, 1], [3, 2]] -> [[1, 1], [3, 3], [3, 1], [3, 2]]
' 依存関数: DynamicCompare
If Not IsArray(arr) Then Err.Raise Number:=13
If IsNull(sortFrom) Then sortFrom = LBound(arr)
If IsNull(sortTo) Then sortTo = UBound(arr)
Dim i As Long, j As Long
Dim swap As Variant
Dim idxToRef1 As Long
Dim idxToRef2 As Long
Dim op As String
If reverse Then
op = "<"
Else
op = ">"
End If
If LBound(arr, 1) > sortFrom Or sortFrom > UBound(arr, 1) Then
Err.Raise 9, Description:="[sortFrom] index(" & sortFrom & ") out of range"
End If
If LBound(arr, 1) > sortTo Or sortTo > UBound(arr, 1) Then
Err.Raise 9, Description:="[sortTo] index(" & sortTo & ") out of range"
End If
If sortFrom > sortTo Then
Err.Raise 513, Description:="sortFrom must be less than or equal to sortTo"
End If
For i = sortFrom + 1 To sortTo
swap = arr(i)
For j = i - 1 To sortFrom Step -1
If IsNull(keyIndex) Then
idxToRef1 = LBound(arr(j))
idxToRef2 = LBound(swap)
Else
idxToRef1 = keyIndex
idxToRef2 = keyIndex
End If
If DynamicCompare(arr(j)(idxToRef1), swap(idxToRef2), op, strSort, ignoreCase) Then
arr(j + 1) = arr(j)
Else
Exit For
End If
Next
arr(j + 1) = swap
Next
End Sub
Public Function MergeSortJaggedArray(ByVal arr As Variant, _
Optional ByVal keyIndex As Variant = Null, _
Optional ByVal reverse As Boolean = False, _
Optional ByVal strSort As Boolean = False, _
Optional ByVal ignoreCase As Boolean = True, _
Optional ByVal header As Boolean = False, _
Optional ByVal sortFrom As Variant = Null, _
Optional ByVal sortTo As Variant = Null) As Variant()
' ジャグ配列をソート(安定ソート)
' keyIndexはソート基準のネストされた配列のインデックスを数字そのままか配列かNullを指定、Nullで配列の最小インデックス
' 配列を指定した場合配列の最初のほうの要素ほどソートの優先度が高い
' 例えばArray(Null, 2, 3)を指定した場合3, 2基準でソート後一番最初の要素基準でソートされる
' reverse:=Trueで降順ソートする
' strSort:=Trueで文字列基準ソート、Falseで数値基準ソート
' ignoreCase:=TrueでstrSort:=Trueの場合に大文字、小文字を区別しないで比較する
' header:=Trueで1番最初の行をソート対象に入れない
' sortFrom: ソート対象行の開始インデックス, Null/数字、Null指定時は最小インデックス、数字指定時はheader指定を無視
' sortTo: ソート対象行の終了インデックス、Null指定時は最大インデックス
' 依存関係の関数
' OffsetArray, SliceArray, ConcatArrays2
' MergeSortJaggedArrayHelper1, MergeSortJaggedArrayHelper2, DynamicCompare
' ArrayLength, ReverseArray
If Not IsArray(arr) Then Err.Raise Number:=13
Dim originalLower As Long, originalUpper As Long
Dim currentUpper As Long
Dim temp As Variant
Dim arrays As New Collection
Dim offsetFlag As Boolean: offsetFlag = False
Dim idx As Variant
If Not IsArray(keyIndex) Then
keyIndex = Array(keyIndex)
End If
If ArrayLength(keyIndex) >= 2 Then
keyIndex = ReverseArray(keyIndex)
End If
If IsNull(sortFrom) Then
sortFrom = LBound(arr)
If header Then
sortFrom = sortFrom + 1
End If
End If
If IsNull(sortTo) Then sortTo = UBound(arr)
If LBound(arr, 1) > sortFrom Or sortFrom > UBound(arr, 1) Then
Err.Raise 9, Description:="[sortFrom] index(" & sortFrom & ") out of range"
End If
If LBound(arr, 1) > sortTo Or sortTo > UBound(arr, 1) Then
Err.Raise 9, Description:="[sortTo] index(" & sortTo & ") out of range"
End If
If sortFrom > sortTo Then
Err.Raise 513, Description:="sortFrom must be less than or equal to sortTo"
End If
originalLower = LBound(arr)
originalUpper = UBound(arr)
' エラー対策のため、開始インデックスが0または1以外の場合0に補正する、後で戻す
' 開始インデックスが2だとエラーになる場合を確認したため
If originalLower <> 0 Or originalLower <> 1 Then
arr = OffsetArray(arr, 0)
offsetFlag = True
End If
sortFrom = sortFrom + LBound(arr) - originalLower
sortTo = sortTo + LBound(arr) - originalLower
currentUpper = UBound(arr)
' sortFrom, sortToを設定した場合はソート範囲と範囲外を切り離してソート後再結合する
If sortFrom <> LBound(arr) Or sortTo <> UBound(arr) Then
If sortFrom <> LBound(arr, 1) Then
temp = SliceArray(arr, LBound(arr), sortFrom - 1)
arrays.add temp
End If
temp = SliceArray(arr, sortFrom, sortTo)
For Each idx In keyIndex
Call MergeSortJaggedArrayHelper1(temp, idx, reverse, strSort, ignoreCase)
Next
arrays.add temp
If sortTo <> currentUpper Then
temp = SliceArray(arr, sortTo + 1, currentUpper)
arrays.add temp
End If
' 結合する、インデックスをずらしている場合はここで戻す
arr = ConcatArrays2(arrays, originalLower)
Else
For Each idx In keyIndex
Call MergeSortJaggedArrayHelper1(arr, idx, reverse, strSort, ignoreCase)
Next
' インデックスをずらしている場合はここで戻す
If offsetFlag Then
arr = OffsetArray(arr, originalLower)
End If
End If
MergeSortJaggedArray = arr
End Function
Private Sub MergeSortJaggedArrayHelper1(ByRef arr As Variant, ByVal keyIndex As Variant, ByVal reverse As Boolean, ByVal strSort As Boolean, ByVal ignoreCase As Boolean)
Dim swap() As Variant
Dim i As Long
Dim idxToRef1 As Long
Dim idxToRef2 As Long
ReDim swap(LBound(arr) To UBound(arr))
Dim tempValues() As Variant
ReDim tempValues(LBound(arr, 1) To UBound(arr, 1))
Dim op As String
If reverse Then
op = ">"
Else
op = "<"
End If
For i = LBound(arr) To UBound(arr) Step 2
If i + 1 > UBound(arr) Then
swap(i) = arr(i)
Exit For
End If
If IsNull(keyIndex) Then
idxToRef1 = LBound(arr(i + 1))
idxToRef2 = LBound(arr(i))
Else
idxToRef1 = keyIndex
idxToRef2 = keyIndex
End If
If DynamicCompare(arr(i + 1)(idxToRef1), arr(i)(idxToRef2), op, strSort, ignoreCase) Then
swap(i) = arr(i + 1)
swap(i + 1) = arr(i)
Else
swap(i) = arr(i)
swap(i + 1) = arr(i + 1)
End If
Next
Dim leftStart As Long
Dim leftEnd As Long
Dim rightStart As Long
Dim rightEnd As Long
Dim n As Long
i = 1
Do While i * 2 <= UBound(arr)
i = i * 2
n = 0
Do While rightEnd + i - 1 < UBound(arr)
n = n + 1
leftStart = i * 2 * (n - 1) + LBound(arr)
leftEnd = i * 2 * (n - 1) + i - 1 + LBound(arr)
rightStart = leftEnd + 1
rightEnd = IIf(rightStart + i - 1 >= UBound(arr), UBound(arr), rightStart + i - 1)
Call MergeSortJaggedArrayHelper2(swap, tempValues, leftStart, leftEnd, rightStart, rightEnd, keyIndex, reverse, strSort, ignoreCase)
Loop
rightEnd = 0
Loop
arr = swap
End Sub
Private Sub MergeSortJaggedArrayHelper2(ByRef swap As Variant, _
ByRef tempValues() As Variant, _
ByVal leftStart As Long, _
ByVal leftEnd As Long, _
ByVal rightStart As Long, _
ByVal rightEnd As Long, _
ByVal keyIndex As Variant, _
ByVal reverse As Boolean, _
ByVal strSort As Boolean, _
ByVal ignoreCase As Boolean)
Dim leftPtr As Long
Dim rightPtr As Long
Dim i As Long
Dim op As String
Dim idxToRef1 As Long
Dim idxToRef2 As Long
Dim flag As Boolean
If reverse Then
op = ">="
Else
op = "<="
End If
For i = leftStart To rightEnd
tempValues(i) = swap(i)
Next
leftPtr = leftStart
rightPtr = rightStart
Do While (leftPtr < leftEnd + 1 Or rightPtr < rightEnd + 1)
flag = False
If rightPtr >= rightEnd + 1 Then
swap(leftPtr + rightPtr - rightStart) = tempValues(leftPtr)
leftPtr = leftPtr + 1
flag = True
ElseIf leftPtr < leftEnd + 1 Then
If IsNull(keyIndex) Then
idxToRef1 = LBound(tempValues(leftPtr))
idxToRef2 = LBound(tempValues(rightPtr))
Else
idxToRef1 = keyIndex
idxToRef2 = keyIndex
End If
If DynamicCompare(tempValues(leftPtr)(idxToRef1), tempValues(rightPtr)(idxToRef2), op, strSort, ignoreCase) Then
swap(leftPtr + rightPtr - rightStart) = tempValues(leftPtr)
leftPtr = leftPtr + 1
flag = True
End If
End If
If Not flag Then
swap(leftPtr + rightPtr - rightStart) = tempValues(rightPtr)
rightPtr = rightPtr + 1
End If
Loop
End Sub
Public Function ReverseArray(ByVal arr As Variant) As Variant()
' 逆順の配列を返す
' ArrayLengthプロシージャと組み合わせてる
Dim result() As Variant
Dim newIdx As Long
Dim i As Long
If Not IsArray(arr) Then Err.Raise Number:=13
If ArrayLength(arr) > 0 Then
ReDim result(LBound(arr) To UBound(arr))
newIdx = LBound(result)
For i = UBound(arr) To LBound(arr) Step -1
If IsObject(arr(i)) Then
Set result(newIdx) = arr(i)
Else
result(newIdx) = arr(i)
End If
newIdx = newIdx + 1
Next
ReverseArray = result
Exit Function
Else
ReverseArray = VBA.Array()
Exit Function
End If
End Function
Public Function ArrayIndexOf(ByVal arr As Variant, ByVal value As Variant, Optional ByVal startIndex As Variant = Null, Optional ByVal endIndex As Variant = Null) As Long
' 配列の中にある要素の最初のインデックスを返す、要素がなければエラー、Integer,Double,Longなどの数値を除き型一致の場合のみ同じ要素とみなす
' startIndex, endIndexで検索範囲を指定可能、Null(デフォルト)の場合は最小インデックスまたは最大インデックスを使用
' 数値以外は厳密な型比較を行う
' ジャグ配列には未対応、オブジェクトは参照先アドレス一致の場合同じ値と判定
' IsStrictlyEqualは依存
If Not IsArray(arr) Then Err.Raise Number:=13
Dim i As Long
Dim result As Variant: result = Null
If IsNull(startIndex) Then startIndex = LBound(arr)
If IsNull(endIndex) Then endIndex = UBound(arr)
For i = startIndex To endIndex
If IsStrictlyEqual(arr(i), value) Then
result = i
Exit For
End If
Next
If IsNull(result) Then
Err.Raise Number:=513, Description:="ValueError: Value is not in array"
End If
ArrayIndexOf = result
End Function
Public Function ArrayIndexOf2(ByVal arr As Variant, ByVal valueList As Variant, Optional ByVal startIndex As Variant = Null, Optional ByVal endIndex As Variant = Null) As Variant()
' 配列の中で指定した要素一覧(配列/コレクション)と等しいすべてのインデックスを配列で返す、要素がなければ空の配列、Integer,Double,Longなどの数値を除き型一致の場合のみ同じ要素とみなす
' startIndex, endIndexで検索範囲を指定可能、Null(デフォルト)の場合は最小インデックスまたは最大インデックスを使用
' 例: ArrayIndexOf2(Array(1, 2, 3, 1, 4), Array(1, 2)) -> [0, 1, 3]
' ArrayIndexOf2(Array(1, 2, 3, 1, 4), Array(1)) -> [0, 3]
' 数値以外は厳密な型比較を行う
' ジャグ配列には未対応、オブジェクトは参照先アドレス一致の場合同じ値と判定
' CollContainsKey, GenerateCollKey, ArrayLengthは依存
If Not IsArray(arr) Then Err.Raise Number:=13
Dim i As Long
Dim item As Variant
Dim key As String
Dim collkeys As New Collection
Dim arrFoundIndexes() As Variant
Dim count As Long
Const caseSensitive As Boolean = True
If IsNull(startIndex) Then startIndex = LBound(arr)
If IsNull(endIndex) Then endIndex = UBound(arr)
' 引数に指定した変数がFor Eachで回せるかチェック(回せないとエラー)
' 同時に判定用のキーを追加
For Each item In valueList
key = GenerateCollKey(item, caseSensitive)
If Not key = "Undefined" And Not CollContainsKey(collkeys, key) Then collkeys.add "", key
Next
ReDim arrFoundIndexes(0 To ArrayLength(arr) + 2)
count = 0
For i = startIndex To endIndex
key = GenerateCollKey(arr(i), caseSensitive)
If CollContainsKey(collkeys, key) And key <> "Undefined" Then
arrFoundIndexes(count) = i
count = count + 1
End If
Next
If count > 0 Then
ReDim Preserve arrFoundIndexes(0 To count - 1)
Else
arrFoundIndexes = VBA.Array()
End If
ArrayIndexOf2 = arrFoundIndexes
End Function
Public Function ConcatArrays(ParamArray arraysToConcat() As Variant) As Variant()
' 2つ以上の配列を結合し、開始インデックス0の新しい配列を返す
' 使用例: arr = ConcatArrays(arr1, arr2)
' 引数の数は制限なし arr = ConcatArrays(arr1, arr2, arr3, arr4)
' 関数ArrayLengthは依存関係
Dim result() As Variant
Dim idx As Long
Dim arr As Variant
Dim item As Variant
Dim resultLen As Long: resultLen = 0
For Each arr In arraysToConcat
If Not IsArray(arr) Then Err.Raise Number:=13
resultLen = resultLen + ArrayLength(arr)
Next arr
If resultLen > 0 Then
ReDim result(0 To resultLen - 1)
idx = -1
For Each arr In arraysToConcat
If ArrayLength(arr) > 0 Then
For Each item In arr
idx = idx + 1
If IsObject(item) Then
Set result(idx) = item
Else
result(idx) = item
End If
Next item
End If
Next arr
ConcatArrays = result
Else
ConcatArrays = VBA.Array()
End If
End Function
Public Function ConcatArrays2(ByVal arraysToConcat As Variant, Optional ByVal firstIndex As Long = 0) As Variant()
' 配列またはコレクション内の配列を結合し、指定したインデックスでスタートする新しい配列を返す
' 使用例: arr = ConcatArrays2(Array(arr1, arr2), 0)
' 結合できる数は制限なし arr = ConcatArrays2(Array(arr1, arr2, arr3, arr4))
' 関数ArrayLengthは依存関係
Dim result() As Variant
Dim idx As Long
Dim arr As Variant
Dim item As Variant
Dim resultLen As Long: resultLen = 0
For Each arr In arraysToConcat
If Not IsArray(arr) Then Err.Raise Number:=13
resultLen = resultLen + ArrayLength(arr)
Next arr
If resultLen > 0 Then
ReDim result(0 + firstIndex To resultLen - 1 + firstIndex)
idx = -1 + firstIndex
For Each arr In arraysToConcat
If ArrayLength(arr) > 0 Then
For Each item In arr
idx = idx + 1
If IsObject(item) Then
Set result(idx) = item
Else
result(idx) = item
End If
Next item
End If
Next arr
ConcatArrays2 = result
Else
ConcatArrays2 = VBA.Array()
End If
End Function
Public Function SliceArray(ByVal arr As Variant, ByVal startIndex As Long, ByVal endIndex As Long) As Variant()
' 配列を指定のインデックスの範囲でスライスし、新規の配列で返す
' 開始インデックスは元の配列の開始インデックスを引き継ぐ
' startIndex, endindex共にスライス範囲に含まれる
If Not IsArray(arr) Then Err.Raise Number:=13
Dim result() As Variant
Dim i As Long
Dim idx As Long
' 範囲外かどうかチェック
If LBound(arr) > startIndex Or startIndex > UBound(arr) Then Err.Raise 9, Description:="[startIndex] index(" & startIndex & ") out of range"
If LBound(arr) > endIndex Or endIndex > UBound(arr) Then Err.Raise 9, Description:="[endIndex] index(" & endIndex & ") out of range"
' 開始インデックス>終了インデックスの場合エラー
If startIndex > endIndex Then Err.Raise 513, Description:="startIndex must be less than or equal to endIndex"
idx = LBound(arr) - 1
ReDim result(LBound(arr) To LBound(arr) + endIndex - startIndex)
For i = startIndex To endIndex
idx = idx + 1
If IsObject(arr(i)) Then
Set result(idx) = arr(i)
Else
result(idx) = arr(i)
End If
Next
SliceArray = result
End Function
Public Sub ArrayPush(ByRef arr As Variant, ByVal value As Variant)
' 動的配列の最後に値を追加する、静的配列に追加しようとするとエラー
' 空配列、未初期化配列ならインデックス0に要素を代入
' 関数ArrayLengthは依存関係
If Not IsArray(arr) Then Err.Raise Number:=13
If ArrayLength(arr) > 0 Then
ReDim Preserve arr(LBound(arr) To UBound(arr) + 1)
Else
ReDim arr(0 To 0)
End If
If IsObject(value) Then
Set arr(UBound(arr)) = value
Else
arr(UBound(arr)) = value
End If
End Sub
Public Sub ExtendArray(ByRef originalArr As Variant, ByVal additionalArr As Variant)
' 動的配列に別の配列を結合する(元の配列を変更)、originalArrが静的配列だとエラーになる
' 関数ArrayLengthは依存関係
Dim item As Variant
Dim idx As Long
If Not IsArray(originalArr) Then Err.Raise Number:=13
If Not IsArray(additionalArr) Then Err.Raise Number:=13
If ArrayLength(originalArr) > 0 Then
idx = UBound(originalArr)
ReDim Preserve originalArr(LBound(originalArr) To UBound(originalArr) + ArrayLength(additionalArr))
Else
If ArrayLength(additionalArr) > 0 Then
idx = -1
ReDim originalArr(0 To ArrayLength(additionalArr) - 1)
End If
End If
If ArrayLength(additionalArr) > 0 Then
For Each item In additionalArr
idx = idx + 1
If IsObject(item) Then
Set originalArr(idx) = item
Else
originalArr(idx) = item
End If
Next
End If
End Sub
Public Function ArrayInsert(ByVal arr As Variant, ByVal index As Long, ByVal value As Variant) As Variant()
' 要素を指定位置に挿入した新規の配列を返す、開始のインデックス番号は維持される
' 要素数0の配列では動作するが、未初期化配列の場合はエラー
If Not IsArray(arr) Then Err.Raise Number:=13
Dim result() As Variant
Dim i As Long
ReDim result(LBound(arr) To UBound(arr) + 1)
For i = LBound(result) To index - 1
If IsObject(arr(i)) Then
Set result(i) = arr(i)
Else
result(i) = arr(i)
End If
Next
If IsObject(value) Then
Set result(index) = value
Else
result(index) = value
End If
For i = index + 1 To UBound(arr) + 1
If IsObject(arr(i - 1)) Then
Set result(i) = arr(i - 1)
Else
result(i) = arr(i - 1)
End If
Next
ArrayInsert = result
End Function
Public Function ArrayRemoveIndex(ByVal arr As Variant, ByVal targetIndex As Variant) As Variant()
' 指定インデックスまたはインデックスのリスト(配列/コレクション/その他イテラブル)に一致する要素を削除した新規の配列を返す、開始のインデックス番号は維持される
' 使用例1: ArrayRemoveIndex(Array("A","B","C","D","E"), 1) -> ["A","C","D","E"]
' 使用例2: ArrayRemoveIndex(Array("A","B","C","D","E"), Array(0, 2, 4)) -> ["B", "D"]
' 依存する関数: CollContainskey, IsIterable
Dim result() As Variant
Dim i As Long
Dim item As Variant
Dim targetIndexCount As Long: targetIndexCount = 0
Dim offset As Long: offset = 0
Dim collkeys As New Collection
If Not IsArray(arr) Then
Err.Raise 13
End If
If Not IsIterable(targetIndex) Then
targetIndex = Array(targetIndex)
End If
' targetIndexの要素数を数えつつ不正な値のチェックとキー判定用コレクションへの値追加を行う
For Each item In targetIndex
If Not IsNumeric(item) Then Err.Raise 13 '数字じゃないものが混ざってたらエラー
collkeys.add "", "key" & CStr(item) ' キー判定用のコレクションにインデックスを追加
Call TypeName(arr(item)) ' インデックスが適切かチェックするために値を参照
targetIndexCount = targetIndexCount + 1
Next item
If UBound(arr) - targetIndexCount >= LBound(arr) Then
ReDim result(LBound(arr) To UBound(arr) - targetIndexCount)
For i = LBound(arr) To UBound(arr)
If Not CollContainsKey(collkeys, "key" & CStr(i)) Then
If IsObject(arr(i)) Then
Set result(i - offset) = arr(i)
Else
result(i - offset) = arr(i)
End If
Else
offset = offset + 1
End If
Next
ArrayRemoveIndex = result
Else
ArrayRemoveIndex = VBA.Array()
End If
End Function
Public Function ArrayRemoveValue(ByVal arr As Variant, ByVal value As Variant) As Variant()
' 配列から特定の値を削除した配列を新規作成して返す
' 該当の値が複数入っていればすべて消す(RubyのDeleteと同じ挙動)
' 値が入っていない場合はエラーになる
' 関数CountValues, IsStrictlyEqualは依存関係
Dim result() As Variant
Dim valueCount As Long
Dim item As Variant
Dim shouldRemove As Boolean
Dim idx As Long
If Not IsArray(arr) Then
Err.Raise Number:=13
Exit Function
End If
valueCount = CountValues(arr, value)
If valueCount = 0 Then
Err.Raise Number:=513, Description:="ValueError: Value is not in array"
Exit Function
End If
If UBound(arr) - valueCount >= LBound(arr) Then
ReDim result(LBound(arr) To UBound(arr) - valueCount)
idx = LBound(arr) - 1
For Each item In arr
shouldRemove = False
If IsStrictlyEqual(item, value) Then shouldRemove = True
If Not shouldRemove Then
idx = idx + 1
If IsObject(item) Then
Set result(idx) = item
Else
result(idx) = item
End If
End If
Next item
ArrayRemoveValue = result
Else
ArrayRemoveValue = VBA.Array()
End If
End Function
Public Function FilterArrayByIndexes(ByVal arr As Variant, ByVal indexes As Variant) As Variant()
' 配列を引数で指定のインデックスの要素のみ取り出す、インデックスはindexesの要素順に取り出される
' indexesは配列またはコレクションで指定可
' 実行例:
' FilterArrayByIndexes(Array("A", "B", "C", "D"), Array(2, 3, 0)) -> ["C","D","A"]
Dim item As Variant
Dim i As Long
Dim index As Variant
Dim size As Long
Dim result() As Variant
If IsArray(indexes) Then
size = UBound(indexes) - LBound(indexes) + 1
Else
size = indexes.count
End If
If size = 0 Then
FilterArrayByIndexes = VBA.Array()
Exit Function
End If
ReDim result(LBound(arr) To size + LBound(arr) - 1)
i = LBound(result)
For Each index In indexes
If IsObject(arr(index)) Then
Set result(i) = arr(index)
Else
result(i) = arr(index)
End If
i = i + 1
Next
FilterArrayByIndexes = result
End Function
Public Function OffsetArray(ByVal arr As Variant, ByVal newFirstIdx As Long) As Variant()
' 1次元配列を任意の開始インデックスに変更したものを新規の配列として取得
If Not IsArray(arr) Then Err.Raise Number:=13
Dim newArr() As Variant
Dim item As Variant
Dim i As Long
ReDim newArr(newFirstIdx To UBound(arr) - LBound(arr) + newFirstIdx)
i = -1 + newFirstIdx
For Each item In arr
i = i + 1
If IsObject(item) Then
Set newArr(i) = item
Else
newArr(i) = item
End If
Next
OffsetArray = newArr
End Function
Public Function ResizeArray(ByVal arr As Variant, ByVal lowerIdx As Long, ByVal upperIdx As Long) As Variant()
' Redim PreserveではLBoundを変更すると要素のインデックスも変わるが、この関数は配列を拡張するのみで元の要素のインデックスには影響しない
If Not IsArray(arr) Then Err.Raise Number:=13
Dim newArr() As Variant
Dim i As Long
' 開始インデックス>終了インデックスの場合エラー
If lowerIdx > upperIdx Then Err.Raise 513, Description:="lowerIdx must be less than or equal to upperIdx"
ReDim newArr(lowerIdx To upperIdx)
For i = lowerIdx To upperIdx
If i >= LBound(arr) And UBound(arr) >= i Then
If IsObject(arr(i)) Then
Set newArr(i) = arr(i)
Else
newArr(i) = arr(i)
End If
End If
Next
ResizeArray = newArr
End Function
Public Function ArrayMax(ByVal arr As Variant) As Double
' 配列の中の要素の最大値を取得する、Empty, 文字列が要素にあるとエラー
' 空の配列でもエラー
' 実行例: ArrayMax(Array(100, -1, 0, 20)) -> 100
If Not IsArray(arr) Then Err.Raise Number:=13
Dim item As Variant
Dim maxValue As Double
Dim flag As Boolean: flag = False
For Each item In arr
If IsArray(item) Or IsObject(item) Or IsNull(item) Or IsEmpty(item) Or TypeName(item) = "String" Then
Err.Raise 13, Description:="TypeError: invalid element in array"
Exit Function
End If
If Not flag Then
maxValue = item
flag = True
End If
If item >= maxValue Then maxValue = item
Next
If Not flag Then
Err.Raise 513, Description:="ValueError: ArrayMax() arg is an empty sequence"
Exit Function
End If
ArrayMax = maxValue
End Function
Public Function ArrayMin(ByVal arr As Variant) As Double
' 配列の中の要素の最小値を取得する、Empty, 文字列が要素にあるとエラー
' 空の配列でもエラー
' 実行例: ArrayMin(Array(100, -1, 0, 20)) -> -1
If Not IsArray(arr) Then Err.Raise Number:=13
Dim item As Variant
Dim minValue As Double
Dim flag As Boolean: flag = False
For Each item In arr
If IsArray(item) Or IsObject(item) Or IsNull(item) Or IsEmpty(item) Or TypeName(item) = "String" Then
Err.Raise 13, Description:="TypeError: invalid element in array"
Exit Function
End If
If Not flag Then
minValue = item
flag = True
End If
If item <= minValue Then minValue = item
Next
If Not flag Then
Err.Raise 513, Description:="ValueError: ArrayMin() arg is an empty sequence"
Exit Function
End If
ArrayMin = minValue
End Function
Public Function ArraySum(ByVal arr As Variant) As Double
' 配列の中の要素の合計を取得する
' Empty, 文字列, オブジェクトが要素にあるとエラー
' 空の配列でもエラー
' 実行例: ArraySum(Array(100, -1, 0, 20)) -> 119
If Not IsArray(arr) Then Err.Raise Number:=13
Dim item As Variant
Dim sumValue As Double
Dim count As Long
For Each item In arr
' 不正な要素を検出
If IsArray(item) Or IsObject(item) Or IsNull(item) Or IsEmpty(item) Or TypeName(item) = "String" Then
Err.Raise 13, Description:="TypeError: invalid element in array"
Exit Function
End If
sumValue = sumValue + item
count = count + 1
Next
' 要素数が0の場合エラー
If count = 0 Then
Err.Raise 513, Description:="ValueError: ArraySum() arg is an empty sequence"
Exit Function
End If
ArraySum = sumValue
End Function
Public Function ArrayAverage(ByVal arr As Variant) As Double
' 配列の中の要素の平均値を取得する
' Empty, 文字列, オブジェクトが要素にあるとエラー
' 空の配列でもエラー
' 実行例: ArrayAverage(Array(100, -1, 0, 20)) -> 29.75
If Not IsArray(arr) Then Err.Raise Number:=13
Dim item As Variant
Dim sumValue As Double
Dim count As Long
For Each item In arr
' 不正な要素を検出
If IsArray(item) Or IsObject(item) Or IsNull(item) Or IsEmpty(item) Or TypeName(item) = "String" Then
Err.Raise 13, Description:="TypeError: invalid element in array"
Exit Function
End If
sumValue = sumValue + item
count = count + 1
Next
' 要素数が0の場合エラー
If count = 0 Then
Err.Raise 513, Description:="ValueError: ArrayAverage() arg is an empty sequence"
Exit Function
End If
ArrayAverage = sumValue / count
End Function
Public Function ArrayMedian(ByVal arr As Variant) As Double
' 配列の中の要素の中央値を取得する
' Empty, 文字列, オブジェクトが要素にあるとエラー
' 空の配列でもエラー
' 実行例: ArrayMedian(Array(100, -1, 0, 20)) -> 10
' 依存関係の関数: QuickSortArray (QuickSortArrayRecursive, ArrayLength)
If Not IsArray(arr) Then Err.Raise Number:=13
Dim item As Variant
Dim values() As Double
Dim count As Long
Dim i As Long, j As Long
Dim temp As Double
ReDim values(1 To 100000)
' 配列の要素を検証しながら数値を格納
For Each item In arr
If IsArray(item) Or IsObject(item) Or IsNull(item) Or IsEmpty(item) Or TypeName(item) = "String" Then
Err.Raise 13, Description:="TypeError: invalid element in array"
Exit Function
End If
count = count + 1
If count > UBound(values) Then
ReDim Preserve values(1 To count * 2)
End If
values(count) = CDbl(item)
Next
' 要素数が0の場合エラー
If count = 0 Then
Err.Raise 513, Description:="ValueError: ArrayMedian() arg is an empty sequence"
Exit Function
End If
ReDim Preserve values(1 To count)
' 昇順ソート
Call QuickSortArray(values)
' 中央値を求める
If count Mod 2 = 1 Then
ArrayMedian = values((count + 1) / 2)
Else
ArrayMedian = (values(count / 2) + values(count / 2 + 1)) / 2
End If
End Function
Private Function MyCVar(ByRef value As Variant) As Variant
' 引数で受け取った変数をそのまま戻り値として返す
' ArrayMapに強制値渡しで引数を渡すためだけに使う関数
' これを経由することでByRef Stringを指定する関数にVariant型の変数を渡せる
' 標準のCVarではCallByNameでObject型指定の引数にCVarで囲んだObject型を渡そうとするとエラーになった
' また括弧で囲むだけだとNothing代入時にエラーになる
' 代わりにこの関数を使用すれば問題なし
If IsObject(value) Then
Set MyCVar = value
Else
MyCVar = value
End If
End Function
Public Function ArrayMap(ByVal procName As String, ByVal arr As Variant, ParamArray args() As Variant) As Variant()
' 配列内の各要素に指定した関数の処理を行った結果の配列を返す
' procName: ユーザー定義関数の名前を文字列で指定
' arr: 対象の配列
' 使用例: ArrayMap("ArrayLength", Array(Array(1, 2, 3), Array(), Array(5))) -> [3, 0, 1]
' 関数はユーザー定義関数である必要があり、組み込みの関数は呼び出せないのでその場合ラッパーを作る必要あり
' 指定する関数は第一引数に配列の各要素を受け取る必要がある
' 第三引数以降にprocNameで指定した関数の第二引数以降を指定可能(最大10個まで)
' 依存関係の関数: ArrayLength, MyCVar
If Not IsArray(arr) Then Err.Raise Number:=13
Dim result() As Variant
Dim i As Long
Dim temp As Variant
Dim argsCount As Long
Dim tempLowerIdx As Long
Const errorDescription As String = "Too many arguments. Maximum allowed is 10."
argsCount = ArrayLength(CVar(args)) ' CVarを経由しないとParamArrayの参照渡しはエラーになる
If argsCount > 10 Then
Err.Raise 513, Description:=errorDescription
Exit Function
End If
If ArrayLength(arr) > 0 Then
ReDim result(LBound(arr) To UBound(arr))
For i = LBound(result) To UBound(result)
' MyCVarで囲んで強制的にByValで引数を渡す(Variant型はByRefのStringの引数とかにそのまま代入できないので)
' MyCVarを経由して計算式扱いにすれば大丈夫
' 括弧で囲むだけでも強制値渡しになるがNothing代入時にエラーになるのでMyCVarを使う
' 組み込み関数のCVarもCallByNameにObjectを渡そうとした場合にエラーが出たので使わない
Select Case argsCount
Case -1: temp = VBA.Array(Application.Run(procName, MyCVar(arr(i))))
Case 0: temp = VBA.Array(Application.Run(procName, MyCVar(arr(i))))
Case 1: temp = VBA.Array(Application.Run(procName, MyCVar(arr(i)), MyCVar(args(0))))
Case 2: temp = VBA.Array(Application.Run(procName, MyCVar(arr(i)), MyCVar(args(0)), MyCVar(args(1))))
Case 3: temp = VBA.Array(Application.Run(procName, MyCVar(arr(i)), MyCVar(args(0)), MyCVar(args(1)), MyCVar(args(2))))
Case 4: temp = VBA.Array(Application.Run(procName, MyCVar(arr(i)), MyCVar(args(0)), MyCVar(args(1)), MyCVar(args(2)), MyCVar(args(3))))
Case 5: temp = VBA.Array(Application.Run(procName, MyCVar(arr(i)), MyCVar(args(0)), MyCVar(args(1)), MyCVar(args(2)), MyCVar(args(3)), MyCVar(args(4))))
Case 6: temp = VBA.Array(Application.Run(procName, MyCVar(arr(i)), MyCVar(args(0)), MyCVar(args(1)), MyCVar(args(2)), MyCVar(args(3)), MyCVar(args(4)), MyCVar(args(5))))
Case 7: temp = VBA.Array(Application.Run(procName, MyCVar(arr(i)), MyCVar(args(0)), MyCVar(args(1)), MyCVar(args(2)), MyCVar(args(3)), MyCVar(args(4)), MyCVar(args(5)), MyCVar(args(6))))
Case 8: temp = VBA.Array(Application.Run(procName, MyCVar(arr(i)), MyCVar(args(0)), MyCVar(args(1)), MyCVar(args(2)), MyCVar(args(3)), MyCVar(args(4)), MyCVar(args(5)), MyCVar(args(6)), MyCVar(args(7))))
Case 9: temp = VBA.Array(Application.Run(procName, MyCVar(arr(i)), MyCVar(args(0)), MyCVar(args(1)), MyCVar(args(2)), MyCVar(args(3)), MyCVar(args(4)), MyCVar(args(5)), MyCVar(args(6)), MyCVar(args(7)), MyCVar(args(8))))
Case 10: temp = VBA.Array(Application.Run(procName, MyCVar(arr(i)), MyCVar(args(0)), MyCVar(args(1)), MyCVar(args(2)), MyCVar(args(3)), MyCVar(args(4)), MyCVar(args(5)), MyCVar(args(6)), MyCVar(args(7)), MyCVar(args(8)), MyCVar(args(9))))
Case Else: Err.Raise 513, Description:=errorDescription
End Select
tempLowerIdx = LBound(temp)
If IsObject(temp(tempLowerIdx)) Then
Set result(i) = temp(tempLowerIdx)
Else
result(i) = temp(tempLowerIdx)
End If
Next
Else
result = VBA.Array()
End If
ArrayMap = result
End Function
Public Function ArrayMap2(ByVal obj As Object, ByVal procName As String, ByVal arr As Variant, ParamArray args() As Variant) As Variant()
' 配列内の各要素に指定したクラスメソッドの処理またはプロパティ参照を行った結果の配列を返す
' Application.Runを使うArrayMapよりも10倍以上高速
' obj: COMオブジェクトやクラスのインスタンス、ワークシートなどの対象のメソッド/プロパティが定義してあるオブジェクト
' procName: メソッド/プロパティの名前を文字列で指定
' arr: 対象の配列
' 使用例1(COMオブジェクトのメソッド):
' ArrayMap2(CreateObject("Scripting.FileSystemObject"), "FolderExists", Array("C:\Windows", "C:\hoge")) -> [True, False]
' 使用例2(ユーザー定義関数を呼び出す):
' 関数をクラスまたはオブジェクトのメソッドとして扱うことで関数も呼び出し可能
' ※以下の場合はClass1という名前のクラスモジュールを作成しArrayLengthをClass1内で定義しておくことでClass1のメソッドとして関数を呼べる
' ArrayMap2(New Class1, "ArrayLength", Array(Array(1, 2, 3), Array(), Array(5))) -> [3, 0, 1]
' もちろんクラスのインスタンスを変数に代入してそれを指定してもOK
' ワークシートまたはユーザーフォーム内に関数を定義した場合も呼び出し可能、その場合はインスタンスの生成が不要
' ※以下はワークシート(Sheet1)に定義したArrayLength関数を呼び出す例
' ArrayMap2(Sheet1, "ArrayLength", Array(Array(1, 2, 3), Array(), Array(5))) -> [3, 0, 1]
' 関数を呼び出す場合はクラスモジュールかワークシートかユーザーフォームの中にPublicで関数を定義する必要がある
' クラスやワークシート、ユーザーフォーム内で定義する場合標準モジュールと名前が被ってもOKなのでそのまま関数コピペでOK
' 指定するメソッド/プロパティは第一引数に配列の各要素を受け取る必要がある
' 第四引数以降にprocNameで指定したメソッド/プロパティの第二引数以降を指定可能(最大10個まで)
' 依存関係の関数: ArrayLength, MyCVar
If Not IsArray(arr) Then Err.Raise Number:=13
Dim result() As Variant
Dim i As Long
Dim temp As Variant
Dim argsCount As Long
Dim shouldRaiseError As Boolean: shouldRaiseError = False
Dim errorNumber As Long
Dim tempLowerIdx As Long
Const errorDescription As String = "Too many arguments. Maximum allowed is 10."
argsCount = ArrayLength(CVar(args)) ' CVarを経由しないとParamArrayの参照渡しはエラーになる
If argsCount > 10 Then
Err.Raise 513, Description:=errorDescription
Exit Function
End If
If ArrayLength(arr) > 0 Then
ReDim result(LBound(arr) To UBound(arr))
For i = LBound(result) To UBound(result)
errorNumber = 0
shouldRaiseError = False
Err.Clear
' プロパティ取得で実行を試み、ダメならメソッド実行してみる
' MyCVarで囲んで強制的にByValで引数を渡す(Variant型はByRefのStringの引数とかにそのまま代入できないので)
' CallByNameの挙動なのか、なぜか引数で渡された配列の要素を添え字参照でそのまま代入すると戻り値がおかしくなることがある
' 例えばfsoのFolderExistsが実在するフォルダでもFalseを返したりする、MyCVarで囲むことで対策可能
' 括弧で囲むだけでも強制値渡しになるがNothing代入時にエラーになるのでMyCVarを使う
' 組み込み関数のCVarもCallByNameにObjectを渡そうとした場合にエラーが出たので使わない
On Error Resume Next
Select Case argsCount
Case -1: temp = VBA.Array(CallByName(obj, procName, VbGet, MyCVar(arr(i))))
Case 0: temp = VBA.Array(CallByName(obj, procName, VbGet, MyCVar(arr(i))))
Case 1: temp = VBA.Array(CallByName(obj, procName, VbGet, MyCVar(arr(i)), MyCVar(args(0))))
Case 2: temp = VBA.Array(CallByName(obj, procName, VbGet, MyCVar(arr(i)), MyCVar(args(0)), MyCVar(args(1))))
Case 3: temp = VBA.Array(CallByName(obj, procName, VbGet, MyCVar(arr(i)), MyCVar(args(0)), MyCVar(args(1)), MyCVar(args(2))))
Case 4: temp = VBA.Array(CallByName(obj, procName, VbGet, MyCVar(arr(i)), MyCVar(args(0)), MyCVar(args(1)), MyCVar(args(2)), MyCVar(args(3))))
Case 5: temp = VBA.Array(CallByName(obj, procName, VbGet, MyCVar(arr(i)), MyCVar(args(0)), MyCVar(args(1)), MyCVar(args(2)), MyCVar(args(3)), MyCVar(args(4))))
Case 6: temp = VBA.Array(CallByName(obj, procName, VbGet, MyCVar(arr(i)), MyCVar(args(0)), MyCVar(args(1)), MyCVar(args(2)), MyCVar(args(3)), MyCVar(args(4)), MyCVar(args(5))))
Case 7: temp = VBA.Array(CallByName(obj, procName, VbGet, MyCVar(arr(i)), MyCVar(args(0)), MyCVar(args(1)), MyCVar(args(2)), MyCVar(args(3)), MyCVar(args(4)), MyCVar(args(5)), MyCVar(args(6))))
Case 8: temp = VBA.Array(CallByName(obj, procName, VbGet, MyCVar(arr(i)), MyCVar(args(0)), MyCVar(args(1)), MyCVar(args(2)), MyCVar(args(3)), MyCVar(args(4)), MyCVar(args(5)), MyCVar(args(6)), MyCVar(args(7))))
Case 9: temp = VBA.Array(CallByName(obj, procName, VbGet, MyCVar(arr(i)), MyCVar(args(0)), MyCVar(args(1)), MyCVar(args(2)), MyCVar(args(3)), MyCVar(args(4)), MyCVar(args(5)), MyCVar(args(6)), MyCVar(args(7)), MyCVar(args(8))))
Case 10: temp = VBA.Array(CallByName(obj, procName, VbGet, MyCVar(arr(i)), MyCVar(args(0)), MyCVar(args(1)), MyCVar(args(2)), MyCVar(args(3)), MyCVar(args(4)), MyCVar(args(5)), MyCVar(args(6)), MyCVar(args(7)), MyCVar(args(8)), MyCVar(args(9))))
Case Else: shouldRaiseError = True
End Select
errorNumber = Err.Number
On Error GoTo 0
If errorNumber = 450 Or errorNumber = 438 Then
Select Case argsCount
Case -1: temp = VBA.Array(CallByName(obj, procName, VbMethod, MyCVar(arr(i))))
Case 0: temp = VBA.Array(CallByName(obj, procName, VbMethod, MyCVar(arr(i))))
Case 1: temp = VBA.Array(CallByName(obj, procName, VbMethod, MyCVar(arr(i)), MyCVar(args(0))))
Case 2: temp = VBA.Array(CallByName(obj, procName, VbMethod, MyCVar(arr(i)), MyCVar(args(0)), MyCVar(args(1))))
Case 3: temp = VBA.Array(CallByName(obj, procName, VbMethod, MyCVar(arr(i)), MyCVar(args(0)), MyCVar(args(1)), MyCVar(args(2))))
Case 4: temp = VBA.Array(CallByName(obj, procName, VbMethod, MyCVar(arr(i)), MyCVar(args(0)), MyCVar(args(1)), MyCVar(args(2)), MyCVar(args(3))))
Case 5: temp = VBA.Array(CallByName(obj, procName, VbMethod, MyCVar(arr(i)), MyCVar(args(0)), MyCVar(args(1)), MyCVar(args(2)), MyCVar(args(3)), MyCVar(args(4))))
Case 6: temp = VBA.Array(CallByName(obj, procName, VbMethod, MyCVar(arr(i)), MyCVar(args(0)), MyCVar(args(1)), MyCVar(args(2)), MyCVar(args(3)), MyCVar(args(4)), MyCVar(args(5))))
Case 7: temp = VBA.Array(CallByName(obj, procName, VbMethod, MyCVar(arr(i)), MyCVar(args(0)), MyCVar(args(1)), MyCVar(args(2)), MyCVar(args(3)), MyCVar(args(4)), MyCVar(args(5)), MyCVar(args(6))))
Case 8: temp = VBA.Array(CallByName(obj, procName, VbMethod, MyCVar(arr(i)), MyCVar(args(0)), MyCVar(args(1)), MyCVar(args(2)), MyCVar(args(3)), MyCVar(args(4)), MyCVar(args(5)), MyCVar(args(6)), MyCVar(args(7))))
Case 9: temp = VBA.Array(CallByName(obj, procName, VbMethod, MyCVar(arr(i)), MyCVar(args(0)), MyCVar(args(1)), MyCVar(args(2)), MyCVar(args(3)), MyCVar(args(4)), MyCVar(args(5)), MyCVar(args(6)), MyCVar(args(7)), MyCVar(args(8))))
Case 10: temp = VBA.Array(CallByName(obj, procName, VbMethod, MyCVar(arr(i)), MyCVar(args(0)), MyCVar(args(1)), MyCVar(args(2)), MyCVar(args(3)), MyCVar(args(4)), MyCVar(args(5)), MyCVar(args(6)), MyCVar(args(7)), MyCVar(args(8)), MyCVar(args(9))))
Case Else: shouldRaiseError = True
End Select
ElseIf errorNumber <> 0 Then
Err.Raise errorNumber
End If
If shouldRaiseError Then
Err.Raise 513, Description:=errorDescription
End If
tempLowerIdx = LBound(temp)
If IsObject(temp(tempLowerIdx)) Then
Set result(i) = temp(tempLowerIdx)
Else
result(i) = temp(tempLowerIdx)
End If
Next
Else
result = VBA.Array()
End If
ArrayMap2 = result
End Function
Public Function ArrayMap3(ByVal procName As String, ByVal arr As Variant, ParamArray args() As Variant) As Variant()
' オブジェクトを代入した配列内の各要素に指定したメソッドの処理またはプロパティ参照を行った結果の配列を返す
' procName: メソッド/プロパティの名前を文字列で指定
' arr: 対象の配列
' 第三引数以降にprocNameで指定したメソッド/プロパティの引数を第一引数から指定可能(最大10個まで)
' 使用例: ArrayMap3("Name", CollectionToArray(ThisWorkbook.Sheets)) -> ["Sheet1", "Sheet2". "Sheet3", "Sheet4"]
' 依存関係の関数: ArrayLength, MyCVar
If Not IsArray(arr) Then Err.Raise Number:=13
Dim result() As Variant
Dim i As Long
Dim temp As Variant
Dim argsCount As Long
Dim shouldRaiseError As Boolean: shouldRaiseError = False
Dim errorNumber As Long
Dim tempLowerIdx As Long
Const errorDescription As String = "Too many arguments. Maximum allowed is 10."
argsCount = ArrayLength(CVar(args)) ' CVarを経由しないとParamArrayの参照渡しはエラーになる
If argsCount > 10 Then
Err.Raise 513, Description:=errorDescription
Exit Function
End If
If ArrayLength(arr) > 0 Then
ReDim result(LBound(arr) To UBound(arr))
For i = LBound(result) To UBound(result)
errorNumber = 0
shouldRaiseError = False
Err.Clear
' プロパティ取得で実行を試み、ダメならメソッド実行してみる
' MyCVarで囲んで強制的にByValで引数を渡す(Variant型はByRefのStringの引数とかにそのまま代入できないので)
' CallByNameの挙動なのか、なぜか引数で渡された配列の要素を添え字参照でそのまま代入すると戻り値がおかしくなることがある
' 例えばfsoのFolderExistsが実在するフォルダでもFalseを返したりする、MyCVarで囲むことで対策可能
' 括弧で囲むだけでも強制値渡しになるがNothing代入時にエラーになるのでMyCVarを使う
' 組み込み関数のCVarもCallByNameにObjectを渡そうとした場合にエラーが出たので使わない
On Error Resume Next
Select Case argsCount
Case -1: temp = VBA.Array(CallByName(MyCVar(arr(i)), procName, VbGet))
Case 0: temp = VBA.Array(CallByName(MyCVar(arr(i)), procName, VbGet))
Case 1: temp = VBA.Array(CallByName(MyCVar(arr(i)), procName, VbGet, MyCVar(args(0))))
Case 2: temp = VBA.Array(CallByName(MyCVar(arr(i)), procName, VbGet, MyCVar(args(0)), MyCVar(args(1))))
Case 3: temp = VBA.Array(CallByName(MyCVar(arr(i)), procName, VbGet, MyCVar(args(0)), MyCVar(args(1)), MyCVar(args(2))))
Case 4: temp = VBA.Array(CallByName(MyCVar(arr(i)), procName, VbGet, MyCVar(args(0)), MyCVar(args(1)), MyCVar(args(2)), MyCVar(args(3))))
Case 5: temp = VBA.Array(CallByName(MyCVar(arr(i)), procName, VbGet, MyCVar(args(0)), MyCVar(args(1)), MyCVar(args(2)), MyCVar(args(3)), MyCVar(args(4))))
Case 6: temp = VBA.Array(CallByName(MyCVar(arr(i)), procName, VbGet, MyCVar(args(0)), MyCVar(args(1)), MyCVar(args(2)), MyCVar(args(3)), MyCVar(args(4)), MyCVar(args(5))))
Case 7: temp = VBA.Array(CallByName(MyCVar(arr(i)), procName, VbGet, MyCVar(args(0)), MyCVar(args(1)), MyCVar(args(2)), MyCVar(args(3)), MyCVar(args(4)), MyCVar(args(5)), MyCVar(args(6))))
Case 8: temp = VBA.Array(CallByName(MyCVar(arr(i)), procName, VbGet, MyCVar(args(0)), MyCVar(args(1)), MyCVar(args(2)), MyCVar(args(3)), MyCVar(args(4)), MyCVar(args(5)), MyCVar(args(6)), MyCVar(args(7))))
Case 9: temp = VBA.Array(CallByName(MyCVar(arr(i)), procName, VbGet, MyCVar(args(0)), MyCVar(args(1)), MyCVar(args(2)), MyCVar(args(3)), MyCVar(args(4)), MyCVar(args(5)), MyCVar(args(6)), MyCVar(args(7)), MyCVar(args(8))))
Case 10: temp = VBA.Array(CallByName(MyCVar(arr(i)), procName, VbGet, MyCVar(args(0)), MyCVar(args(1)), MyCVar(args(2)), MyCVar(args(3)), MyCVar(args(4)), MyCVar(args(5)), MyCVar(args(6)), MyCVar(args(7)), MyCVar(args(8)), MyCVar(args(9))))
Case Else: shouldRaiseError = True
End Select
errorNumber = Err.Number
On Error GoTo 0
If errorNumber = 450 Or errorNumber = 438 Then
Select Case argsCount
Case -1: temp = VBA.Array(CallByName(MyCVar(arr(i)), procName, VbMethod))
Case 0: temp = VBA.Array(CallByName(MyCVar(arr(i)), procName, VbMethod))
Case 1: temp = VBA.Array(CallByName(MyCVar(arr(i)), procName, VbMethod, MyCVar(args(0))))
Case 2: temp = VBA.Array(CallByName(MyCVar(arr(i)), procName, VbMethod, MyCVar(args(0)), MyCVar(args(1))))
Case 3: temp = VBA.Array(CallByName(MyCVar(arr(i)), procName, VbMethod, MyCVar(args(0)), MyCVar(args(1)), MyCVar(args(2))))
Case 4: temp = VBA.Array(CallByName(MyCVar(arr(i)), procName, VbMethod, MyCVar(args(0)), MyCVar(args(1)), MyCVar(args(2)), MyCVar(args(3))))
Case 5: temp = VBA.Array(CallByName(MyCVar(arr(i)), procName, VbMethod, MyCVar(args(0)), MyCVar(args(1)), MyCVar(args(2)), MyCVar(args(3)), MyCVar(args(4))))
Case 6: temp = VBA.Array(CallByName(MyCVar(arr(i)), procName, VbMethod, MyCVar(args(0)), MyCVar(args(1)), MyCVar(args(2)), MyCVar(args(3)), MyCVar(args(4)), MyCVar(args(5))))
Case 7: temp = VBA.Array(CallByName(MyCVar(arr(i)), procName, VbMethod, MyCVar(args(0)), MyCVar(args(1)), MyCVar(args(2)), MyCVar(args(3)), MyCVar(args(4)), MyCVar(args(5)), MyCVar(args(6))))
Case 8: temp = VBA.Array(CallByName(MyCVar(arr(i)), procName, VbMethod, MyCVar(args(0)), MyCVar(args(1)), MyCVar(args(2)), MyCVar(args(3)), MyCVar(args(4)), MyCVar(args(5)), MyCVar(args(6)), MyCVar(args(7))))
Case 9: temp = VBA.Array(CallByName(MyCVar(arr(i)), procName, VbMethod, MyCVar(args(0)), MyCVar(args(1)), MyCVar(args(2)), MyCVar(args(3)), MyCVar(args(4)), MyCVar(args(5)), MyCVar(args(6)), MyCVar(args(7)), MyCVar(args(8))))
Case 10: temp = VBA.Array(CallByName(MyCVar(arr(i)), procName, VbMethod, MyCVar(args(0)), MyCVar(args(1)), MyCVar(args(2)), MyCVar(args(3)), MyCVar(args(4)), MyCVar(args(5)), MyCVar(args(6)), MyCVar(args(7)), MyCVar(args(8)), MyCVar(args(9))))
Case Else: shouldRaiseError = True
End Select
ElseIf errorNumber <> 0 Then
Err.Raise errorNumber
End If
If shouldRaiseError Then
Err.Raise 513, Description:=errorDescription
End If
tempLowerIdx = LBound(temp)
If IsObject(temp(tempLowerIdx)) Then
Set result(i) = temp(tempLowerIdx)
Else
result(i) = temp(tempLowerIdx)
End If
Next
Else
result = VBA.Array()
End If
ArrayMap3 = result
End Function
Public Function IsInitializedArray(ByVal arr As Variant) As Boolean
' 配列が初期化済かどうか判定、配列以外を渡すとエラー
Dim temp As Variant
If Not IsArray(arr) Then
Err.Raise Number:=13
Exit Function
End If
On Error GoTo Exception
temp = LBound(arr)
On Error GoTo 0
IsInitializedArray = True
Exit Function
Exception:
' 未初期化配列のFalse
If Err.Number <> 9 Then
Err.Raise Number:=Err.Number
Exit Function
End If
IsInitializedArray = False
End Function
Public Function ArrayEquals(ByVal arr1 As Variant, ByVal arr2 As Variant, Optional ByVal ignoreIdxDiff As Boolean = True) As Boolean
' 配列同士を比較し同じ要素を含んだ配列ならTrueを返す、配列を含んだ配列は同じ配列同士を比較してもFalseを返すので注意
' ignoreIdxDiff:=Trueで開始インデックスの違いを無視して比較する
' 依存関数: IsInitializedArray, ArrayLength, IsStrictlyEqual
Dim arr1Len As Long
Dim arr2Len As Long
Dim i As Long
Dim item As Variant
ArrayEquals = False
' 配列でないものはエラー
If Not IsArray(arr1) Or Not IsArray(arr2) Then
Err.Raise Number:=13
Exit Function
End If
' 未初期化配列同士ならTrue
If Not IsInitializedArray(arr1) And Not IsInitializedArray(arr2) Then
ArrayEquals = True
Exit Function
End If
' どちらかが未初期化配列ならFalse
If Not IsInitializedArray(arr1) Or Not IsInitializedArray(arr2) Then
Exit Function
End If
arr1Len = ArrayLength(arr1)
arr2Len = ArrayLength(arr2)
' 長さが違う時点でFalse
If arr1Len <> arr2Len Then
Exit Function
End If
' 開始インデックスが異なり、ignoreIdxDiffがFalseの時点でFalse
If Not (LBound(arr1) = LBound(arr2)) And Not ignoreIdxDiff Then
Exit Function
End If
' 開始インデックスが0同士ならTrue
If arr1Len = 0 And arr2Len = 0 Then
ArrayEquals = True
Exit Function
End If
' すべての要素が一致したらTrue
i = LBound(arr2)
For Each item In arr1
If Not IsStrictlyEqual(item, arr2(i)) Then
Exit Function
End If
i = i + 1
Next
ArrayEquals = True
End Function
Public Sub ReplaceValueInArray(ByRef arr As Variant, ByVal value As Variant, ByVal newValue As Variant)
' 配列の特定要素を置換する(元の配列を直接変更)
' 置換するかの判定は型を厳密にチェックする(数値を除く)
' 実行例: ([Null, "A", "B", "C", Null], Null, Empty) -> [Empty, "A", "B", "C", Empty]
' 依存する関数: ArrayLength, IsStrictlyEqual
If Not IsArray(arr) Then Err.Raise Number:=13
Dim i As Long
If Not ArrayLength(arr) > 0 Then Exit Sub
For i = LBound(arr) To UBound(arr)
If IsStrictlyEqual(arr(i), value) Then
If IsObject(newValue) Then
Set arr(i) = newValue
Else
arr(i) = newValue
End If
End If
Next i
End Sub
Public Function GetMissingNumbers(ByVal numberList As Variant, ByVal startNum As Long, ByVal endNum As Long) As Variant()
' 指定の数の範囲内で指定した数字入りの配列・コレクションに含まれていない数を配列で返す
' 実行例: GetMissingNumbers(Array(1, 2, 3), 0, 7) -> [0, 4, 5, 6, 7]
' ArrayIndexOf2、ArrayRemoveIndexと組み合わせて使う想定(要素が含まれていないインデックスを消す用途)
' 依存関数: GenerateCollKey
Const caseSensitive As Boolean = True
Dim i As Long
Dim item As Variant
Dim key As String
Dim count As Long
Dim result() As Variant
ReDim result(0 To endNum - startNum + 2)
Dim collkeys As New Collection
For Each item In numberList
If IsObject(item) Or IsNull(item) Or IsEmpty(item) Or TypeName(item) = "String" Or Not IsNumeric(item) Then
Err.Raise 13, Description:="TypeError: invalid element in numberList"
Exit Function
End If
key = GenerateCollKey(item, caseSensitive)
If Not key = "Undefined" And Not CollContainsKey(collkeys, key) Then collkeys.add "", key
Next
count = 0
For i = startNum To endNum
key = GenerateCollKey(i, caseSensitive)
If Not CollContainsKey(collkeys, key) And key <> "Undefined" Then
result(count) = i
count = count + 1
End If
Next
If count > 0 Then
ReDim Preserve result(0 To count - 1)
Else
result = VBA.Array()
End If
GetMissingNumbers = result
End Function
Public Function ContainsValue(ByVal itemList As Variant, ByVal value As Variant) As Boolean
' 指定した要素が配列/コレクション/Dictionaryに含まれているかチェック
' itemList：チェック先の配列/コレクション/Dictionary
' value：チェック対象
' 数値以外は厳密な型比較を行う
' itemList内の要素が配列の場合未対応、オブジェクトは参照先アドレス一致の場合同じ値と判定
' IsStrictlyEqualは依存関数
Dim item As Variant
Dim temp As Variant
If LCase(TypeName(itemList)) = "dictionary" Then
itemList = itemList.items
End If
If IsArray(itemList) Then
On Error GoTo Finally
' 未初期化配列 -> False
temp = LBound(itemList)
On Error GoTo 0
End If
For Each item In itemList
If IsStrictlyEqual(item, value) Then
ContainsValue = True
Exit Function
End If
Next
Finally:
ContainsValue = False
End Function
Public Function CountValues(ByVal itemList As Variant, ByVal value As Variant) As Long
' 配列/Collection/Dictionaryの特定の要素の数を返す
' itemList - 検索対象の配列/Collection/Dictionary
' value - 数える要素
' 数値以外は厳密な型比較を行う
' itemList内の要素が配列の場合未対応、オブジェクトは参照先アドレス一致の場合同じ値と判定
' IsStrictlyEqualは依存関数
Dim result As Long
Dim item As Variant
Dim temp As Variant
result = 0
If LCase(TypeName(itemList)) = "dictionary" Then
itemList = itemList.items
End If
If IsArray(itemList) Then
On Error GoTo Finally
' 未初期化配列 -> 0
temp = LBound(itemList)
On Error GoTo 0
End If
For Each item In itemList
If IsStrictlyEqual(item, value) Then result = result + 1
Next
CountValues = result
Exit Function
Finally:
CountValues = 0
End Function
Public Function IsStrictlyEqual(ByVal value1 As Variant, ByVal value2 As Variant) As Boolean
' データ型の一致を含めた厳密等価比較を行う
' ただし、Integer, Long, Doubleなどの数値は同一視して比較する
' Boolean, Dateは数値と同一視しない
Dim t1 As VbVarType, t2 As VbVarType
t1 = VarType(value1)
t2 = VarType(value2)
' Objectは参照先が同じ場合にTrue
' 必ず先にオブジェクトから比較する(.Valueなしの空のセルとEmptyが一致判定をしないようにするため)
' (他のオブジェクトとその他のデータ型を両方保持する変数についても同様)
If IsObject(value1) Or IsObject(value2) Then
If IsObject(value1) And IsObject(value2) Then
IsStrictlyEqual = (value1 Is value2)
End If
Exit Function
End If
' Null / Empty
If IsNull(value1) Or IsNull(value2) Then
IsStrictlyEqual = (IsNull(value1) And IsNull(value2))
Exit Function
ElseIf IsEmpty(value1) Or IsEmpty(value2) Then
IsStrictlyEqual = (IsEmpty(value1) And IsEmpty(value2))
Exit Function
End If
' 配列は未対応（要件次第で拡張）
If IsArray(value1) Or IsArray(value2) Then
IsStrictlyEqual = False
Exit Function
End If
' エラー値
If t1 = vbError Or t2 = vbError Then
IsStrictlyEqual = (t1 = t2 And value1 = value2)
Exit Function
End If
' String, Date, Boolean
If (t1 = vbString Or t2 = vbString) Or (t1 = vbDate Or t2 = vbDate) Or (t1 = vbBoolean Or t2 = vbBoolean) Then
IsStrictlyEqual = (t1 = t2 And value1 = value2)
Exit Function
End If
' それ以外のデータ型(数値など)
On Error Resume Next
IsStrictlyEqual = (value1 = value2)
Exit Function
On Error GoTo 0
IsStrictlyEqual = False
End Function
Public Function IsIterable(ByVal value As Variant) As Boolean
' 配列、コレクションなどのForEachで回せるオブジェクトに対してTrueを返す
Dim temp As Variant
IsIterable = True
On Error GoTo Exception
For Each temp In value
Exit Function
Next
Exit Function
Exception:
IsIterable = False
End Function
Public Function IterableCount(ByVal iterable As Variant) As Long
' 配列、コレクションなどのForEachで回せるオブジェクトの中身の個数を数える
Dim i As Long
Dim item As Variant
i = 0
For Each item In iterable
i = i + 1
Next
IterableCount = i
End Function
Public Function ArrayDuplicateIndexes(ByVal arr As Variant, Optional ByVal caseSensitive As Boolean = True) As Variant()
' 配列から重複している要素のインデックスを配列で取得
' 実行例: ArrayDuplicateIndexes(Array(1, 1, 3, 1, 3, 2, 4)) -> [1, 3, 4]
' caseSensitive=Trueで大文字・小文字を区別する、Falseで区別しない
' caseSensitive=Trueの場合内部でUnicodeに変換するため速度は落ちる
' 数値以外は型を厳密に比較する、例えばEmptyについては空文字や0と別の値として扱う
' 依存する関数:ArrayLength, GenerateCollKey, CollContainsKey, StringToUnicode
If Not IsArray(arr) Then Err.Raise Number:=13
Dim collkeys As New Collection
Dim key As String
Dim result() As Variant
Dim i As Long, i2 As Long
Dim flag As Boolean: flag = False
i2 = 0
If ArrayLength(arr) > 0 Then
ReDim result(0 To ArrayLength(arr) - 1)
For i = LBound(arr) To UBound(arr)
key = GenerateCollKey(arr(i), caseSensitive)
If key = "Undefined" Then
flag = True
Else
If Not CollContainsKey(collkeys, key) Then
collkeys.add "", key
flag = False
Else
flag = True
End If
End If
If flag Then
result(i2) = i
i2 = i2 + 1
End If
flag = False
Next
End If
If Not 0 >= i2 Then
ReDim Preserve result(0 To i2 - 1)
Else
result = VBA.Array()
End If
ArrayDuplicateIndexes = result
End Function
Public Function ArrayRemoveDuplicates(ByVal arr As Variant, Optional ByVal caseSensitive As Boolean = True) As Variant()
' 重複を削除した配列を新規作成して返す
' caseSensitive=Trueで大文字・小文字を区別する、Falseで区別しない
' caseSensitive=Trueの場合内部でUnicodeに変換するため速度は落ちる
' Emptyについては空文字や0と別の値として扱う
' 関数CreateUniqueCollWithKeys, CollContainsKey, GenerateCollKey, StringToUnicodeは依存関係
If Not IsArray(arr) Then Err.Raise Number:=13
Dim item As Variant
Dim result() As Variant
Dim tempColl As Collection
Dim i As Long
If ArrayLength(arr) > 0 Then
Set tempColl = CreateUniqueCollWithKeys(arr, caseSensitive)
Else
Set tempColl = New Collection
End If
If tempColl.count > 0 Then
i = LBound(arr) - 1
ReDim result(LBound(arr) To tempColl.count + LBound(arr) - 1)
For Each item In tempColl
i = i + 1
If IsObject(item) Then
Set result(i) = item
Else
result(i) = item
End If
Next
Else
result = VBA.Array()
End If
ArrayRemoveDuplicates = result
End Function
Public Function CollRemoveDuplicates(ByVal coll As Collection, Optional ByVal caseSensitive As Boolean = True) As Collection
' 重複を削除したコレクションを新規作成して返す
' ArrayRemoveDuplicatesのコレクション版
' 関数CreateUniqueCollWithKeys, CollContainsKey, GenerateCollKey, StringToUnicodeは依存関係
Dim item As Variant
Dim resultColl As New Collection
Dim tempColl As Collection
If coll.count > 0 Then
Set tempColl = CreateUniqueCollWithKeys(coll, caseSensitive)
Else
Set tempColl = New Collection
End If
If tempColl.count > 0 Then
For Each item In tempColl
resultColl.add item
Next
End If
Set CollRemoveDuplicates = resultColl
End Function
Private Function CreateUniqueCollWithKeys(ByVal itemList As Variant, ByVal caseSensitive As Boolean) As Collection
' 配列・コレクションを引数にとりキーの存在チェックを利用して重複しないアイテムのリストを作成する
Dim item As Variant
Dim uniqueColl As New Collection
Dim key As String
For Each item In itemList
key = GenerateCollKey(item, caseSensitive)
If key = "Undefined" Then
uniqueColl.add item
Else
If Not CollContainsKey(uniqueColl, key) Then
uniqueColl.add item, key
End If
End If
Next
Set CreateUniqueCollWithKeys = uniqueColl
End Function
Private Function StringToUnicode(ByVal inputStr As String) As String
' "abc" -> "97/98/99", "ABC" -> "65/66/67", "あいうえお" -> "12354/12356/12358/12360/12362"
Dim i As Long, n As Long
If Len(inputStr) = 0 Then StringToUnicode = "": Exit Function
n = Len(inputStr)
Dim parts() As Variant
ReDim parts(0 To n - 1)
For i = 1 To n
parts(i - 1) = AscW(Mid$(inputStr, i, 1))
Next
StringToUnicode = Join(parts, "/")
End Function
Public Function GenerateCollKey(ByVal value As Variant, Optional ByVal caseSensitive As Boolean = True) As String
' 重複削除用のコレクションに使うデータ型を識別するためのキーを作成する
' caseSensitive=TrueでUnicodeに変換し文字列は大文字と小文字を区別する(コレクションのキーは大文字・小文字を区別しないためUnicodeに変換する)
' caseSensitive=Trueの場合Unicodeに変換するため速度は落ちる
' この関数を重複チェックに用いる場合、戻り値が"Undefined"の場合に重複としてカウントしないように使う側で処理を分岐させること
' 関数StringToUnicodeは依存関係
' 変換例
' Object -> "__Object__123456" (オブジェクトのポインタ)
' Null -> "__Null__"
' Empty -> "__Empty__"
' "abc" -> "__UnicodeString__97/98/99" or "__String__abc"
' "ABC" -> "__UnicodeString__65/66/67" or "__String__abc"
' "123" -> "__UnicodeString__49/50/51" or "__String__123"
' 123 -> "____123"
' True -> "__Boolean__True"
' False -> "__Boolean__False"
' #11/1/2017# -> "__Date__2017/11/01"
' #11/1/2017 9:10:30 AM# -> "__Date__2017/11/01 9:10:30"
' CVErr(2015) -> "__Error__エラー 2015" (日本語環境の場合)
' Array(1, 2, 3) -> "Undefined"
Dim result As String
' 必ず先にオブジェクトから変換する(.Valueなしの空のセルとEmptyが同じ文字列にならないようにするため)
If IsObject(value) Then
result = "__Object__" & ObjPtr(value)
ElseIf IsNull(value) Then
result = "__Null__"
ElseIf IsEmpty(value) Then
result = "__Empty__"
ElseIf IsError(value) Then
result = "__Error__" & CStr(value)
ElseIf TypeName(value) = "String" Then
If caseSensitive Then
result = "__UnicodeString__" & StringToUnicode(value)
Else
result = "__String__" & LCase(value)
End If
Else
If TypeName(value) = "Boolean" Then
If value Then
result = "__Boolean__" & "True"
Else
result = "__Boolean__" & "False"
End If
ElseIf TypeName(value) = "Date" Then
result = "__Date__" & CStr(value)
Else
On Error GoTo Exception
result = "____" & CStr(value)
On Error GoTo 0
End If
End If
GenerateCollKey = result
Exit Function
Exception:
result = "Undefined"
GenerateCollKey = result
Exit Function
End Function
Public Function CreateColl(ParamArray items() As Variant) As Collection
' Array関数のコレクション版
' 引数に何も指定していない場合要素数0のコレクションを返す
Dim result As Collection
Set result = New Collection
Dim item As Variant
For Each item In items
result.add item
Next item
Set CreateColl = result
End Function
Public Function ArrayToCollection(ByVal arr As Variant) As Collection
' 配列をコレクションに変換する
' ArrayLengthは依存
Dim coll As New Collection
Dim i As Long
If Not IsArray(arr) Then
Err.Raise Number:=13
Exit Function
End If
If ArrayLength(arr) > 0 Then
For i = LBound(arr) To UBound(arr)
coll.add arr(i)
Next i
End If
Set ArrayToCollection = coll
End Function
Public Function CollectionToArray(ByVal coll As Variant, Optional ByVal isStartIdx1 As Boolean = False) As Variant()
' コレクションを配列に変換
' ThisWorkbook.Sheets, Application.Workbooks, Application.RecentFilesのようなExcelのコレクション型オブジェクトも対応
' isStartIdx1はTrueにすると開始インデックスが1の配列を作成(コレクションと番号を合わせる)
Dim arr() As Variant
Dim item As Variant
Dim idx As Long
Dim itemCount As Long
itemCount = coll.count
If itemCount > 0 Then
If isStartIdx1 Then
ReDim arr(1 To itemCount)
Else
ReDim arr(0 To itemCount - 1)
End If
idx = LBound(arr)
For Each item In coll
' オブジェクトの代入時はSetを使用
If IsObject(item) Then
Set arr(idx) = item
Else
arr(idx) = item
End If
idx = idx + 1
Next
Else
arr = VBA.Array()
End If
CollectionToArray = arr
End Function
Public Function NestedCollectionToArray(ByVal coll As Variant, Optional ByVal isStartIdx1 As Boolean = False) As Variant()
' 多重ネストしたコレクションを再帰的に配列に変換
' CollectionToArray関数を依存関数として利用
' 使い道･･･VBA-JSONでJSON配列から変換されたコレクションを配列に戻す
Dim baseArr() As Variant
Dim item As Variant
Dim idx As Long
' まず1層目を配列化
baseArr = CollectionToArray(coll, isStartIdx1)
' 各要素をチェックして再帰処理
For idx = LBound(baseArr) To UBound(baseArr)
If IsObject(baseArr(idx)) Then
' オブジェクトが Collection なら再帰呼び出し
If TypeName(baseArr(idx)) = "Collection" Then
baseArr(idx) = NestedCollectionToArray(baseArr(idx), isStartIdx1)
End If
End If
Next
NestedCollectionToArray = baseArr
End Function
Public Function CollContainsKey(ByVal coll As Collection, ByVal key As String) As Boolean
' コレクションの特定のキーが存在するか確認する
CollContainsKey = False
If coll Is Nothing Then Exit Function
If coll.count = 0 Then Exit Function
On Error GoTo Exception
Call coll.item(key)
On Error GoTo 0
CollContainsKey = True
Exit Function
Exception:
CollContainsKey = False
Exit Function
End Function
Public Function ReverseCollection(ByVal coll As Collection) As Collection
' 逆順にしたコレクションを返す、キーは失われる
' 高速化のため、内部的には配列に変換して処理する
' CollectionToArray、ArrayToCollectionを依存する関数として利用
Dim resultColl As Collection
Dim arr() As Variant
If coll.count > 0 Then
arr = CollectionToArray(coll)
arr = ReverseArray(arr)
Set resultColl = ArrayToCollection(arr)
Else
Set resultColl = New Collection
End If
Set ReverseCollection = resultColl
End Function
Public Function QuickSortCollection(ByVal coll As Collection, _
Optional ByVal reverse As Boolean = False, _
Optional ByVal strSort As Boolean = False, _
Optional ByVal ignoreCase As Boolean = True) As Collection
' ソートしたコレクションを返す、キーは失われる
' クイックソートを使用
' オブジェクト型が入った状態でソートするとエラーになる
' 高速化のため、内部的には配列に変換して処理する
' reverse:=Trueで降順ソートする
' strSort:=Trueで文字列基準ソート、Falseで数値基準ソート
' ignoreCase:=TrueでstrSort:=Trueの場合に大文字、小文字を区別しないで比較する
' QuickSortArray, CollectionToArray、ArrayToCollectionを依存する関数として利用
Dim resultColl As Collection
Dim arr() As Variant
If coll.count > 0 Then
arr = CollectionToArray(coll)
Call QuickSortArray(arr, reverse, strSort, ignoreCase)
Set resultColl = ArrayToCollection(arr)
Else
Set resultColl = New Collection
End If
Set QuickSortCollection = resultColl
End Function
Public Sub ExtendCollection(ByRef originalColl As Variant, ByVal additionalColl As Variant)
' 2つのCollectionまたはArrayListを結合(元のコレクションを変更する)
' originalCollのキーは保持されるが、additionalCollのキーは失われる
' .Addメソッドがあるオブジェクト(Dictionaryを除く)ならなんでも使用可
Dim item As Variant
For Each item In additionalColl
originalColl.add item
Next item
End Sub
Public Function ConcatCollections(ParamArray collections() As Variant) As Collection
' 2つ以上のコレクションを結合し、新しいコレクションを返す
' 使用例: Set coll = ConcatCollections(col1, col2)
' 引数の数は制限なし Set coll = ConcatCollections(col1, col2, col3, col4)
Dim result As New Collection
Dim col As Variant
Dim item As Variant
For Each col In collections
If TypeName(col) = "Collection" Then
For Each item In col
result.add item
Next item
Else
Err.Raise Number:=13
Exit Function
End If
Next col
Set ConcatCollections = result
End Function
Public Function ConcatCollections2(ByVal collections As Variant) As Collection
' 配列またはコレクション内のコレクションを結合し、新しいコレクションを返す
' 使用例: Set coll = ConcatCollections2(Array(col1, col2))
' 結合できる数は制限なし Set coll = ConcatCollections2(Array(col1, col2, col3, col4))
Dim result As New Collection
Dim col As Variant
Dim item As Variant
For Each col In collections
If TypeName(col) = "Collection" Then
For Each item In col
result.add item
Next item
Else
Err.Raise Number:=13
Exit Function
End If
Next col
Set ConcatCollections2 = result
End Function
Public Function CollRemoveValue(ByVal coll As Variant, ByVal value As Variant) As Collection
' コレクションから特定の値を削除したコレクションを新規作成して返す、キーは失われる
' 値が入っていない場合はエラーになる
' 関数IsStrictlyEqual, CountValuesは依存関係
Dim result As Collection
Set result = New Collection
Dim valueCount As Long
Dim item As Variant
Dim shouldRemove As Boolean
valueCount = CountValues(coll, value)
If valueCount = 0 Then
Err.Raise Number:=513, Description:="ValueError: Value is not in collection"
Exit Function
End If
For Each item In coll
shouldRemove = False
If IsStrictlyEqual(item, value) Then shouldRemove = True
If Not shouldRemove Then
result.add item
End If
Next item
Set CollRemoveValue = result
End Function
Public Function Reverse2DArrayV(ByVal arr2d As Variant) As Variant()
' 縦方向に反転した二次元配列を返す
If Not IsArray(arr2d) Then Err.Raise Number:=13
Dim newArr() As Variant
Dim lower1 As Long, upper1 As Long, lower2 As Long, upper2 As Long
Dim i As Long, j As Long, i2 As Long
lower1 = LBound(arr2d, 1)
upper1 = UBound(arr2d, 1)
lower2 = LBound(arr2d, 2)
upper2 = UBound(arr2d, 2)
ReDim newArr(lower1 To upper1, lower2 To upper2)
i2 = lower1
For i = upper1 To lower1 Step -1
For j = lower2 To upper2
If IsObject(arr2d(i, j)) Then
Set newArr(i2, j) = arr2d(i, j)
Else
newArr(i2, j) = arr2d(i, j)
End If
Next j
i2 = i2 + 1
Next i
Reverse2DArrayV = newArr
End Function
Public Function Reverse2DArrayH(ByVal arr2d As Variant) As Variant()
' 横方向に反転した二次元配列を返す
If Not IsArray(arr2d) Then Err.Raise Number:=13
Dim newArr() As Variant
Dim lower1 As Long, upper1 As Long, lower2 As Long, upper2 As Long
Dim i As Long, j As Long, j2 As Long
lower1 = LBound(arr2d, 1)
upper1 = UBound(arr2d, 1)
lower2 = LBound(arr2d, 2)
upper2 = UBound(arr2d, 2)
ReDim newArr(lower1 To upper1, lower2 To upper2)
For i = lower1 To upper1
j2 = lower2
For j = upper2 To lower2 Step -1
If IsObject(arr2d(i, j)) Then
Set newArr(i, j2) = arr2d(i, j)
Else
newArr(i, j2) = arr2d(i, j)
End If
j2 = j2 + 1
Next j
Next i
Reverse2DArrayH = newArr
End Function
Public Function Transpose2DArray(ByVal arr2d As Variant) As Variant()
' 二次元配列の行と列を入れ替える
' WorksheetFunctionのTransposeとは違って行数の制限なし
If Not IsArray(arr2d) Then Err.Raise Number:=13
Dim i As Long, j As Long
Dim newArr() As Variant
ReDim newArr(LBound(arr2d, 2) To UBound(arr2d, 2), LBound(arr2d, 1) To UBound(arr2d, 1))
For i = LBound(newArr, 1) To UBound(newArr, 1)
For j = LBound(newArr, 2) To UBound(newArr, 2)
If IsObject(arr2d(j, i)) Then
Set newArr(i, j) = arr2d(j, i)
Else
newArr(i, j) = arr2d(j, i)
End If
Next j
Next i
Transpose2DArray = newArr
End Function
Public Function TransposeJaggedArray(ByVal arr As Variant) As Variant()
' ジャグ配列の行と列を入れ替える
' 各配列の開始・終了インデックスはすべて同じである必要がある
' Array(Array(1, 2, 3, 4), Array(5, 6, 7, 8), Array(9, 10, 11, 12))の場合
' [[1, 2, 3, 4], [5, 6, 7, 8], [9, 10, 11, 12]] -> [[1, 5, 9], [2, 6, 10], [3, 7, 11], [4, 8, 12]]
If Not IsArray(arr) Then Err.Raise Number:=13
Dim i As Long, j As Long
Dim newArr() As Variant
Dim lowerRow As Long, upperRow As Long
Dim lowerCol As Long, upperCol As Long
Dim item As Variant
' 外側の配列と内側の配列の開始、終了インデックスを取得
lowerRow = LBound(arr)
upperRow = UBound(arr)
lowerCol = LBound(arr(lowerRow))
upperCol = UBound(arr(lowerRow))
' 内側の配列の開始・終了インデックスがすべて一致しているかを確認
For Each item In arr
If LBound(item) <> lowerCol Or UBound(item) <> upperCol Then
Err.Raise Number:=513, Description:="All inner arrays must have the same starting and ending index."
End If
Next
ReDim newArr(lowerCol To upperCol)
For i = lowerCol To upperCol
' 各配列を初期化
Dim tempRow() As Variant
ReDim tempRow(lowerRow To upperRow)
For j = lowerRow To upperRow
If IsObject(arr(j)(i)) Then
Set tempRow(j) = arr(j)(i)
Else
tempRow(j) = arr(j)(i)
End If
Next j
newArr(i) = tempRow
Next i
TransposeJaggedArray = newArr
End Function
Public Function Array1DTo2DV(ByVal arr1d As Variant) As Variant()
' 1次元配列を縦方向に展開した列要素数1の二次元配列に変換
If Not IsArray(arr1d) Then Err.Raise Number:=13
Dim arr2d() As Variant
ReDim arr2d(LBound(arr1d) To UBound(arr1d), LBound(arr1d) To LBound(arr1d))
Dim i As Long
Dim arr1dLower As Long: arr1dLower = LBound(arr1d)
For i = LBound(arr2d, 1) To UBound(arr2d, 1)
If IsObject(arr1d(i)) Then
Set arr2d(i, arr1dLower) = arr1d(i)
Else
arr2d(i, arr1dLower) = arr1d(i)
End If
Next i
Array1DTo2DV = arr2d
End Function
Public Function Array1DTo2DH(ByVal arr1d As Variant) As Variant()
' 1次元配列を横方向に展開した行要素数1の二次元配列に変換
If Not IsArray(arr1d) Then Err.Raise Number:=13
Dim arr2d() As Variant
ReDim arr2d(LBound(arr1d) To LBound(arr1d), LBound(arr1d) To UBound(arr1d))
Dim i As Long
Dim arr1dLower As Long: arr1dLower = LBound(arr1d)
For i = LBound(arr2d, 2) To UBound(arr2d, 2)
If IsObject(arr1d(i)) Then
Set arr2d(arr1dLower, i) = arr1d(i)
Else
arr2d(arr1dLower, i) = arr1d(i)
End If
Next i
Array1DTo2DH = arr2d
End Function
Public Function Concat2DArraysV(ByVal arraysToConcat As Variant, Optional ByVal newFirstRow As Long = 0, Optional ByVal newFirstCol As Long = 0) As Variant()
' 二次元配列を縦方向に結合する
' arraysToConcat: 二次元配列の配列 (例: Array(arr1, arr2, arr3))
' newFirstRow: 結合先の開始行番号
' newFirstCol: 結合先の開始列番号
'
' 各配列の列は開始列番号からの相対位置で結合される
' 例: arr1の列1はnewFirstCol列に、arr2の列1もnewFirstCol列に対応して配置される
Dim arr2d As Variant
Dim r As Long, c As Long
Dim totalRows As Long
Dim maxCols As Long
Dim rowOffset As Long
Dim tempRows As Long
Dim tempCols As Long
Dim result() As Variant
' --- 総行数と最大列数を計算 ---
totalRows = 0
maxCols = 0
For Each arr2d In arraysToConcat
If Not IsArray(arr2d) Then Err.Raise Number:=13
tempRows = ArrayLength(arr2d, 1)
tempCols = ArrayLength(arr2d, 2)
totalRows = totalRows + tempRows
If tempCols > maxCols Then maxCols = tempCols
Next arr2d
' --- 結合結果の配列を確保 ---
ReDim result(0 + newFirstRow To totalRows - 1 + newFirstRow, 0 + newFirstCol To maxCols - 1 + newFirstCol)
' --- データをコピー ---
rowOffset = newFirstRow
For Each arr2d In arraysToConcat
tempRows = ArrayLength(arr2d, 1)
tempCols = ArrayLength(arr2d, 2)
If tempRows > 0 And tempCols > 0 Then
For r = 0 To tempRows - 1
For c = 0 To tempCols - 1
If IsObject(arr2d(LBound(arr2d, 1) + r, LBound(arr2d, 2) + c)) Then
Set result(rowOffset + r, newFirstCol + c) = arr2d(LBound(arr2d, 1) + r, LBound(arr2d, 2) + c)
Else
result(rowOffset + r, newFirstCol + c) = arr2d(LBound(arr2d, 1) + r, LBound(arr2d, 2) + c)
End If
Next c
Next r
rowOffset = rowOffset + tempRows
End If
Next arr2d
Concat2DArraysV = result
End Function
Public Function Concat2DArraysH(ByVal arraysToConcat As Variant, Optional ByVal newFirstRow As Long = 0, Optional ByVal newFirstCol As Long = 0) As Variant()
' 二次元配列を横方向に結合する
' arraysToConcat: 二次元配列の配列 (例: Array(arr1, arr2, arr3))
' newFirstRow: 結合結果配列の開始行番号
' newFirstCol: 結合結果配列の開始列番号
'
' 各配列の行は開始行番号からの相対位置で配置される
' 行数が異なる配列も最大行数に合わせて結合される
Dim arr2d As Variant
Dim r As Long, c As Long
Dim totalCols As Long
Dim maxRows As Long
Dim colOffset As Long
Dim tempRows As Long
Dim tempCols As Long
Dim result() As Variant
' --- 総列数と最大行数を計算 ---
totalCols = 0
maxRows = 0
For Each arr2d In arraysToConcat
If Not IsArray(arr2d) Then Err.Raise Number:=13
tempRows = ArrayLength(arr2d, 1)
tempCols = ArrayLength(arr2d, 2)
totalCols = totalCols + tempCols
If tempRows > maxRows Then maxRows = tempRows
Next arr2d
' --- 結果配列を確保 ---
ReDim result(0 + newFirstRow To maxRows - 1 + newFirstRow, 0 + newFirstCol To totalCols - 1 + newFirstCol)
' --- データをコピー ---
colOffset = newFirstCol
For Each arr2d In arraysToConcat
tempRows = ArrayLength(arr2d, 1)
tempCols = ArrayLength(arr2d, 2)
If tempRows > 0 And tempCols > 0 Then
For r = 0 To tempRows - 1
For c = 0 To tempCols - 1
If IsObject(arr2d(LBound(arr2d, 1) + r, LBound(arr2d, 2) + c)) Then
Set result(newFirstRow + r, colOffset + c) = arr2d(LBound(arr2d, 1) + r, LBound(arr2d, 2) + c)
Else
result(newFirstRow + r, colOffset + c) = arr2d(LBound(arr2d, 1) + r, LBound(arr2d, 2) + c)
End If
Next c
Next r
colOffset = colOffset + tempCols
End If
Next arr2d
Concat2DArraysH = result
End Function
Public Function Offset2DArray(ByVal arr2d As Variant, ByVal newFirstRow As Long, ByVal newFirstCol As Long) As Variant()
' 二次元配列の行・列の開始インデックスを変更して新しい配列を返す
If Not IsArray(arr2d) Then Err.Raise Number:=13
Dim newArr() As Variant
Dim r As Long, c As Long
Dim oldLBoundRow As Long, oldUBoundRow As Long
Dim oldLBoundCol As Long, oldUBoundCol As Long
Dim newUBoundRow As Long, newUBoundCol As Long
' 元の配列の範囲を取得
oldLBoundRow = LBound(arr2d, 1)
oldUBoundRow = UBound(arr2d, 1)
oldLBoundCol = LBound(arr2d, 2)
oldUBoundCol = UBound(arr2d, 2)
' 新しい配列の範囲を設定
newUBoundRow = newFirstRow + (oldUBoundRow - oldLBoundRow)
newUBoundCol = newFirstCol + (oldUBoundCol - oldLBoundCol)
' 新しい配列を再定義
ReDim newArr(newFirstRow To newUBoundRow, newFirstCol To newUBoundCol)
' 値をコピー
For r = oldLBoundRow To oldUBoundRow
For c = oldLBoundCol To oldUBoundCol
If IsObject(arr2d(r, c)) Then
Set newArr(r - oldLBoundRow + newFirstRow, c - oldLBoundCol + newFirstCol) = arr2d(r, c)
Else
newArr(r - oldLBoundRow + newFirstRow, c - oldLBoundCol + newFirstCol) = arr2d(r, c)
End If
Next c
Next r
Offset2DArray = newArr
End Function
Public Function Slice2DArray(ByVal arr2d As Variant, ByVal startRow As Long, ByVal endRow As Long, ByVal startCol As Long, ByVal endCol As Long) As Variant()
' 配列を指定のインデックスの範囲でスライスし、新規の配列で返す
' 開始インデックスは元の配列の開始インデックスを引き継ぐ
' startRowx, endRow, startCol, endCol自身はスライス範囲に含まれる
If Not IsArray(arr2d) Then Err.Raise Number:=13
Dim result() As Variant
Dim i As Long
Dim j As Long
Dim rowIdx As Long
Dim colIdx As Long
' 範囲外かどうかチェック
If LBound(arr2d, 1) > startRow Or startRow > UBound(arr2d, 1) Then Err.Raise 9, Description:="[startRow] index(" & startRow & ") out of range"
If LBound(arr2d, 1) > endRow Or endRow > UBound(arr2d, 1) Then Err.Raise 9, Description:="[endRow] index(" & endRow & ") out of range"
If LBound(arr2d, 2) > startCol Or startCol > UBound(arr2d, 2) Then Err.Raise 9, Description:="[startCol] index(" & startCol & ") out of range"
If LBound(arr2d, 2) > endCol Or endCol > UBound(arr2d, 2) Then Err.Raise 9, Description:="[endCol] index(" & endCol & ") out of range"
' 開始インデックス>終了インデックスの場合エラー
If startRow > endRow Then Err.Raise 513, Description:="startRow must be less than or equal to endRow"
If startCol > endCol Then Err.Raise 513, Description:="startCol must be less than or equal to endCol"
ReDim result(LBound(arr2d, 1) To LBound(arr2d, 1) + endRow - startRow, LBound(arr2d, 2) To LBound(arr2d, 2) + endCol - startCol)
rowIdx = LBound(arr2d, 1) - 1
For i = startRow To endRow
colIdx = LBound(arr2d, 2) - 1
rowIdx = rowIdx + 1
For j = startCol To endCol
colIdx = colIdx + 1
If IsObject(arr2d(i, j)) Then
Set result(rowIdx, colIdx) = arr2d(i, j)
Else
result(rowIdx, colIdx) = arr2d(i, j)
End If
Next j
Next i
Slice2DArray = result
End Function
Public Function Resize2DArray(ByVal arr2d As Variant, ByVal lowerRow As Long, ByVal upperRow As Long, ByVal lowerCol As Long, ByVal upperCol As Long) As Variant
' ReDim Preserveでは一番上の次元しか変更できないのでこちらを使う
' 既存の要素のインデックスは変わらない
If Not IsArray(arr2d) Then Err.Raise Number:=13
Dim result() As Variant
Dim i As Long
Dim j As Long
' 開始インデックス>終了インデックスの場合エラー
If lowerRow > upperRow Then Err.Raise 513, Description:="lowerRow must be less than or equal to upperRow"
If lowerCol > upperCol Then Err.Raise 513, Description:="lowerCol must be less than or equal to upperCol"
ReDim result(lowerRow To upperRow, lowerCol To upperCol)
For i = lowerRow To upperRow
If i >= LBound(arr2d, 1) And UBound(arr2d, 1) >= i Then
For j = lowerCol To upperCol
If j >= LBound(arr2d, 2) And UBound(arr2d, 2) >= j Then
If IsObject(arr2d(i, j)) Then
Set result(i, j) = arr2d(i, j)
Else
result(i, j) = arr2d(i, j)
End If
End If
Next j
End If
Next
Resize2DArray = result
End Function
Public Function Extract2DArrayCol(ByRef arr2d As Variant, ByVal colIdx As Long) As Variant
' 二次元配列から列番号を指定して一次元配列として抽出する
If Not IsArray(arr2d) Then Err.Raise Number:=13
Dim arr1d() As Variant
Dim i As Long
' 範囲外かどうかチェック
If LBound(arr2d, 2) > colIdx Or colIdx > UBound(arr2d, 2) Then Err.Raise 9, Description:="[colIdx] index(" & colIdx & ") out of range"
ReDim arr1d(LBound(arr2d, 1) To UBound(arr2d, 1))
For i = LBound(arr1d) To UBound(arr1d)
If IsObject(arr2d(i, colIdx)) Then
Set arr1d(i) = arr2d(i, colIdx)
Else
arr1d(i) = arr2d(i, colIdx)
End If
Next i
Extract2DArrayCol = arr1d
End Function
Public Function Extract2DArrayRow(ByRef arr2d As Variant, ByVal rowIdx As Long) As Variant
' 二次元配列から行番号を指定して一次元配列として抽出する
If Not IsArray(arr2d) Then Err.Raise Number:=13
Dim arr1d() As Variant
Dim i As Long
' 範囲外かどうかチェック
If LBound(arr2d, 1) > rowIdx Or rowIdx > UBound(arr2d, 1) Then Err.Raise 9, Description:="[rowIdx] index(" & rowIdx & ") out of range"
ReDim arr1d(LBound(arr2d, 2) To UBound(arr2d, 2))
For i = LBound(arr1d) To UBound(arr1d)
If IsObject(arr2d(rowIdx, i)) Then
Set arr1d(i) = arr2d(rowIdx, i)
Else
arr1d(i) = arr2d(rowIdx, i)
End If
Next i
Extract2DArrayRow = arr1d
End Function
Public Function ArrayJaggedTo2D(ByVal jaggedArr As Variant, Optional ByVal firstRow As Long = 0, Optional ByVal firstCol As Long = 0) As Variant()
' ジャグ配列を二次元配列に変換
If Not IsArray(jaggedArr) Then Err.Raise Number:=13
Dim memberArr As Variant
Dim item As Variant
Dim rowIdx As Long, colIdx As Long
Dim result() As Variant
Dim maxSize As Long
Dim size As Long
maxSize = 0
For Each memberArr In jaggedArr
size = ArrayLength(memberArr)
If size >= maxSize Then maxSize = size
Next
ReDim result(firstRow To ArrayLength(jaggedArr) + firstRow - 1, firstCol To maxSize + firstCol - 1)
rowIdx = firstRow
For Each memberArr In jaggedArr
colIdx = firstCol
For Each item In memberArr
If IsObject(item) Then
Set result(rowIdx, colIdx) = item
Else
result(rowIdx, colIdx) = item
End If
colIdx = colIdx + 1
Next
rowIdx = rowIdx + 1
Next
ArrayJaggedTo2D = result
End Function
Public Function Array2DToJagged(ByVal arr2d As Variant) As Variant()
If Not IsArray(arr2d) Then Err.Raise Number:=13
Dim result() As Variant
Dim temp As Variant
Dim i As Long, j As Long
ReDim result(LBound(arr2d, 1) To UBound(arr2d, 1))
For i = LBound(result) To UBound(result)
temp = Empty
ReDim temp(LBound(arr2d, 2) To UBound(arr2d, 2))
result(i) = temp
Next i
temp = Empty
For i = LBound(arr2d, 1) To UBound(arr2d, 1)
For j = LBound(arr2d, 2) To UBound(arr2d, 2)
If IsObject(arr2d(i, j)) Then
Set result(i)(j) = arr2d(i, j)
Else
result(i)(j) = arr2d(i, j)
End If
Next j
Next i
Array2DToJagged = result
End Function
Public Sub Paste1DArrayTo2DArrayV(ByRef arr2d As Variant, ByVal arr1d As Variant, ByVal startRow As Long, ByVal startCol As Long)
' 1次元配列を二次元配列の特定位置に縦方向に貼り付ける
' 2次元配列の長さが足りない場合はエラー
' 依存する関数: ArrayLength
If Not IsArray(arr2d) Then Err.Raise Number:=13
If Not IsArray(arr1d) Then Err.Raise Number:=13
Dim item As Variant
Dim idx As Long
' startRow, startColが範囲外ならエラー
If LBound(arr2d, 1) > startRow Or startRow > UBound(arr2d, 1) Then
Err.Raise 9, Description:="[startRow] index(" & startRow & ") out of range"
End If
If LBound(arr2d, 2) > startCol Or startCol > UBound(arr2d, 2) Then
Err.Raise 9, Description:="[startCol] index(" & startCol & ") out of range"
End If
' 二次元配列の行の長さが貼り付ける一次元配列に対して足りない場合はエラー
If ArrayLength(arr1d) > (ArrayLength(arr2d, 1) - startRow + LBound(arr2d, 1)) Then
Err.Raise 513, Description:="arr1d length must be less than or equal to the available rows in arr2d."
End If
If ArrayLength(arr1d) = 0 Then Exit Sub
idx = startRow
For Each item In arr1d
If IsObject(item) Then
Set arr2d(idx, startCol) = item
Else
arr2d(idx, startCol) = item
End If
idx = idx + 1
Next item
End Sub
Public Sub Paste1DArrayTo2DArrayH(ByRef arr2d As Variant, ByVal arr1d As Variant, ByVal startRow As Long, ByVal startCol As Long)
' 1次元配列を二次元配列の特定位置に横方向に貼り付ける
' 2次元配列の長さが足りない場合はエラー
' 依存する関数: ArrayLength
If Not IsArray(arr2d) Then Err.Raise Number:=13
If Not IsArray(arr1d) Then Err.Raise Number:=13
Dim item As Variant
Dim idx As Long
' startRow, startColが範囲外ならエラー
If LBound(arr2d, 1) > startRow Or startRow > UBound(arr2d, 1) Then
Err.Raise 9, Description:="[startRow] index(" & startRow & ") out of range"
End If
If LBound(arr2d, 2) > startCol Or startCol > UBound(arr2d, 2) Then
Err.Raise 9, Description:="[startCol] index(" & startCol & ") out of range"
End If
' 二次元配列の列の長さが貼り付ける一次元配列に対して足りない場合はエラー
If ArrayLength(arr1d) > (ArrayLength(arr2d, 2) - startCol + LBound(arr2d, 2)) Then
Err.Raise 513, Description:="arr1d length must be less than or equal to the available columns in arr2d."
End If
If ArrayLength(arr1d) = 0 Then Exit Sub
idx = startCol
For Each item In arr1d
If IsObject(item) Then
Set arr2d(startRow, idx) = item
Else
arr2d(startRow, idx) = item
End If
idx = idx + 1
Next item
End Sub
Public Function MergeSort2DArray(ByVal arr2d As Variant, ByVal keyCol As Variant, _
Optional ByVal reverse As Boolean = False, _
Optional ByVal strSort As Boolean = False, _
Optional ByVal ignoreCase As Boolean = True, _
Optional ByVal header As Boolean = False, _
Optional ByVal sortFrom As Variant = Null, _
Optional ByVal sortTo As Variant = Null) As Variant()
' 二次元配列を指定の列インデックスをキーとしてソート(安定ソート)
' keyColはNullか数字またはその配列を指定、配列を指定した場合配列の最初のほう要素ほどソートの優先度が高い
' reverse:=Trueで降順ソートする
' strSort:=Trueで文字列基準ソート、Falseで数値基準ソート
' ignoreCase:=TrueでstrSort:=Trueの場合に大文字、小文字を区別しないで比較する
' header:=Trueで1番最初の行をソート対象に入れない
' sortFrom: ソート対象行の開始インデックス, Null/数字、Null指定時は最小インデックス、数字指定時はheader指定を無視
' sortTo: ソート対象行の終了インデックス、Null指定時は最大インデックス
' 依存関係の関数
' Offset2DArray, Slice2DArray, Concat2DArraysV
' MergeSort2DArrayHelper1, MergeSort2DArrayHelper2, DynamicCompare
' ArrayLength, ReverseArray
If Not IsArray(arr2d) Then Err.Raise Number:=13
Dim originalLowerRow As Long, originalUpperRow As Long
Dim originalLowerCol As Long, originalUpperCol As Long
Dim currentUpperRow As Long
Dim currentLowerCol As Long
Dim temp As Variant
Dim idx As Variant
Dim idx2 As Long
Dim arrays As New Collection
Dim offsetFlag As Boolean: offsetFlag = False
If Not IsArray(keyCol) Then
keyCol = Array(keyCol)
End If
If ArrayLength(keyCol) >= 2 Then
keyCol = ReverseArray(keyCol)
End If
' ソート基準列に範囲外のインデックスがあるかどうか事前にチェック、あればエラーを起こす
For Each idx In keyCol
If Not IsNull(idx) Then
If LBound(arr2d, 2) > idx Or idx > UBound(arr2d, 2) Then
Err.Raise 9, Description:="[keyCol] index(" & idx & ") out of range"
End If
End If
Next
If IsNull(sortFrom) Then
sortFrom = LBound(arr2d, 1)
If header Then
sortFrom = sortFrom + 1
End If
End If
If IsNull(sortTo) Then sortTo = UBound(arr2d, 1)
If LBound(arr2d, 1) > sortFrom Or sortFrom > UBound(arr2d, 1) Then
Err.Raise 9, Description:="[sortFrom] index(" & sortFrom & ") out of range"
End If
If LBound(arr2d, 1) > sortTo Or sortTo > UBound(arr2d, 1) Then
Err.Raise 9, Description:="[sortTo] index(" & sortTo & ") out of range"
End If
If sortFrom > sortTo Then
Err.Raise 513, Description:="sortFrom must be less than or equal to sortTo"
End If
originalLowerRow = LBound(arr2d, 1)
originalUpperRow = UBound(arr2d, 1)
originalLowerCol = LBound(arr2d, 2)
originalUpperCol = UBound(arr2d, 2)
' エラー対策のため、開始インデックスの行、列が0または1以外の場合0に補正する、後で戻す
' 開始の行、列が2だとエラーになる場合を確認したため
If originalLowerRow <> 0 Or originalLowerRow <> 1 Or originalLowerCol <> 0 Or originalLowerCol <> 1 Then
arr2d = Offset2DArray(arr2d, 0, 0)
offsetFlag = True
End If
sortFrom = sortFrom + LBound(arr2d, 1) - originalLowerRow
sortTo = sortTo + LBound(arr2d, 1) - originalLowerRow
currentUpperRow = UBound(arr2d, 1)
currentLowerCol = LBound(arr2d, 2)
' sortFrom, sortToを設定した場合はソート範囲と範囲外を切り離してソート後再結合する
If sortFrom <> LBound(arr2d, 1) Or sortTo <> UBound(arr2d, 1) Then
If sortFrom <> LBound(arr2d, 1) Then
temp = Slice2DArray(arr2d, LBound(arr2d, 1), sortFrom - 1, LBound(arr2d, 2), UBound(arr2d, 2))
arrays.add temp
End If
temp = Slice2DArray(arr2d, sortFrom, sortTo, LBound(arr2d, 2), UBound(arr2d, 2))
For Each idx In keyCol
' 列をずらした分の差分を計算, Nullの場合はずらす前の最小列インデックスに対して差分を適用する
If IsNull(idx) Then
idx2 = originalLowerCol + currentLowerCol - originalLowerCol
Else
idx2 = idx + currentLowerCol - originalLowerCol
End If
Call MergeSort2DArrayHelper1(temp, idx2, reverse, strSort, ignoreCase)
Next
arrays.add temp
If sortTo <> currentUpperRow Then
temp = Slice2DArray(arr2d, sortTo + 1, currentUpperRow, LBound(arr2d, 2), UBound(arr2d, 2))
arrays.add temp
End If
' 結合する、行、列をずらしている場合はここで戻す
arr2d = Concat2DArraysV(arrays, originalLowerRow, originalLowerCol)
Else
For Each idx In keyCol
If IsNull(idx) Then
idx2 = originalLowerCol + currentLowerCol - originalLowerCol
Else
idx2 = idx + currentLowerCol - originalLowerCol
End If
Call MergeSort2DArrayHelper1(arr2d, idx2, reverse, strSort, ignoreCase)
Next
' 行、列をずらしている場合はここで戻す
If offsetFlag Then
arr2d = Offset2DArray(arr2d, originalLowerRow, originalLowerCol)
End If
End If
MergeSort2DArray = arr2d
End Function
Private Sub MergeSort2DArrayHelper1(ByRef arr2d As Variant, ByVal keyCol As Long, ByVal reverse As Boolean, ByVal strSort As Boolean, ByVal ignoreCase As Boolean)
' MergeSort2DArray内で使用するソートプログラム
' 開始インデックスが0または1以外の配列で使おうとするとエラーになるので注意
Dim swap() As Variant
Dim indexBuffer() As Variant
Dim tempValues() As Variant
Dim tempIndexes() As Variant
Dim i As Long
Dim op As String
If reverse Then
op = ">"
Else
op = "<"
End If
ReDim swap(LBound(arr2d, 1) To UBound(arr2d, 1))
ReDim indexBuffer(LBound(arr2d, 1) To UBound(arr2d, 1))
ReDim tempValues(LBound(arr2d, 1) To UBound(arr2d, 1))
ReDim tempIndexes(LBound(arr2d, 1) To UBound(arr2d, 1))
For i = LBound(arr2d, 1) To UBound(arr2d, 1) Step 2
If i + 1 > UBound(arr2d, 1) Then
swap(i) = arr2d(i, keyCol)
indexBuffer(i) = i
Exit For
End If
If DynamicCompare(arr2d(i + 1, keyCol), arr2d(i, keyCol), op, strSort, ignoreCase) Then
swap(i) = arr2d(i + 1, keyCol)
swap(i + 1) = arr2d(i, keyCol)
indexBuffer(i) = i + 1
indexBuffer(i + 1) = i
Else
swap(i) = arr2d(i, keyCol)
swap(i + 1) = arr2d(i + 1, keyCol)
indexBuffer(i) = i
indexBuffer(i + 1) = i + 1
End If
Next
Dim leftStart As Long
Dim leftEnd As Long
Dim rightStart As Long
Dim rightEnd As Long
Dim n As Long
i = 1
Do While i * 2 <= UBound(arr2d, 1)
i = i * 2
n = 0
Do While rightEnd + i - 1 < UBound(arr2d, 1)
n = n + 1
leftStart = i * 2 * (n - 1) + LBound(arr2d, 1)
leftEnd = i * 2 * (n - 1) + i - 1 + LBound(arr2d, 1)
rightStart = leftEnd + 1
rightEnd = IIf(rightStart + i - 1 >= UBound(arr2d, 1), UBound(arr2d, 1), rightStart + i - 1)
Call MergeSort2DArrayHelper2(swap, indexBuffer, tempValues, tempIndexes, leftStart, leftEnd, rightStart, rightEnd, reverse, strSort, ignoreCase)
Loop
rightEnd = 0
Loop
Dim result As Variant
Dim j As Long
ReDim result(LBound(arr2d, 1) To UBound(arr2d, 1), LBound(arr2d, 2) To UBound(arr2d, 2))
For i = LBound(arr2d, 1) To UBound(arr2d, 1)
For j = LBound(arr2d, 2) To UBound(arr2d, 2)
If IsObject(arr2d(indexBuffer(i), j)) Then
Set result(i, j) = arr2d(indexBuffer(i), j)
Else
result(i, j) = arr2d(indexBuffer(i), j)
End If
Next
Next
arr2d = result
End Sub
Private Sub MergeSort2DArrayHelper2(ByRef swap As Variant, _
ByRef indexBuffer() As Variant, _
ByRef tempValues() As Variant, _
ByRef tempIndexes() As Variant, _
ByVal leftStart As Long, _
ByVal leftEnd As Long, _
ByVal rightStart As Long, _
ByVal rightEnd As Long, _
ByVal reverse As Boolean, _
ByVal strSort As Boolean, _
ByVal ignoreCase As Boolean)
Dim leftPtr As Long
Dim rightPtr As Long
Dim i As Long
Dim op As String
If reverse Then
op = ">="
Else
op = "<="
End If
For i = leftStart To rightEnd
tempValues(i) = swap(i)
tempIndexes(i) = indexBuffer(i)
Next
leftPtr = leftStart
rightPtr = rightStart
Do While (leftPtr < leftEnd + 1 Or rightPtr < rightEnd + 1)
If rightPtr >= rightEnd + 1 Then
swap(leftPtr + rightPtr - rightStart) = tempValues(leftPtr)
indexBuffer(leftPtr + rightPtr - rightStart) = tempIndexes(leftPtr)
leftPtr = leftPtr + 1
ElseIf leftPtr < leftEnd + 1 And DynamicCompare(tempValues(leftPtr), tempValues(rightPtr), op, strSort, ignoreCase) Then
swap(leftPtr + rightPtr - rightStart) = tempValues(leftPtr)
indexBuffer(leftPtr + rightPtr - rightStart) = tempIndexes(leftPtr)
leftPtr = leftPtr + 1
Else
swap(leftPtr + rightPtr - rightStart) = tempValues(rightPtr)
indexBuffer(leftPtr + rightPtr - rightStart) = tempIndexes(rightPtr)
rightPtr = rightPtr + 1
End If
Loop
End Sub
Public Function Array2DRemoveRowIndex(ByVal arr2d As Variant, ByVal targetIndex As Variant) As Variant()
' 二次元配列から指定のインデックスを数字またはインデックスのリスト(配列/コレクション/その他イテラブル)に一致する行要素を削除した新規の二次元配列を返す、開始のインデックス番号は維持される
' 依存する関数: CollContainskey, IsIterable
Dim result() As Variant
Dim i As Long
Dim j As Long
Dim item As Variant
Dim targetIndexCount As Long: targetIndexCount = 0
Dim offset As Long: offset = 0
Dim collkeys As New Collection
If Not IsArray(arr2d) Then
Err.Raise 13
End If
If Not IsIterable(targetIndex) Then
targetIndex = Array(targetIndex)
End If
' targetIndexの要素数を数えつつ不正な値のチェックとキー判定用コレクションへの値追加を行う
For Each item In targetIndex
If Not IsNumeric(item) Then Err.Raise 13 '数字じゃないものが混ざってたらエラー
collkeys.add "", "key" & CStr(item) ' キー判定用のコレクションにインデックスを追加
Call TypeName(arr2d(item, LBound(arr2d, 2))) 'インデックスが適切かチェックするために値を参照
targetIndexCount = targetIndexCount + 1
Next item
If UBound(arr2d, 1) - targetIndexCount >= LBound(arr2d, 1) Then
ReDim result(LBound(arr2d, 1) To UBound(arr2d, 1) - targetIndexCount, LBound(arr2d, 2) To UBound(arr2d, 2))
For i = LBound(arr2d, 1) To UBound(arr2d, 1)
If Not CollContainsKey(collkeys, "key" & CStr(i)) Then
For j = LBound(arr2d, 2) To UBound(arr2d, 2)
If IsObject(arr2d(i, j)) Then
Set result(i - offset, j) = arr2d(i, j)
Else
result(i - offset, j) = arr2d(i, j)
End If
Next
Else
offset = offset + 1
End If
Next
Array2DRemoveRowIndex = result
Else
Array2DRemoveRowIndex = VBA.Array()
End If
End Function
Public Function Array2DRemoveColIndex(ByVal arr2d As Variant, ByVal targetIndex As Variant) As Variant()
' 二次元配列から指定のインデックスを数字またはインデックスのリスト(配列/コレクション/その他イテラブル)に一致する列要素を削除した新規の二次元配列を返す、開始のインデックス番号は維持される
' 依存する関数: CollContainskey, IsIterable
Dim result() As Variant
Dim i As Long
Dim j As Long
Dim item As Variant
Dim targetIndexCount As Long: targetIndexCount = 0
Dim offset As Long: offset = 0
Dim collkeys As New Collection
If Not IsArray(arr2d) Then
Err.Raise 13
End If
If Not IsIterable(targetIndex) Then
targetIndex = Array(targetIndex)
End If
' targetIndexの要素数を数えつつ不正な値のチェックとキー判定用コレクションへの値追加を行う
For Each item In targetIndex
If Not IsNumeric(item) Then Err.Raise 13 '数字じゃないものが混ざってたらエラー
collkeys.add "", "key" & CStr(item) ' キー判定用のコレクションにインデックスを追加
Call TypeName(arr2d(LBound(arr2d, 1), item)) ' インデックスが適切かチェックするために値を参照
targetIndexCount = targetIndexCount + 1
Next item
If UBound(arr2d, 2) - targetIndexCount >= LBound(arr2d, 2) Then
ReDim result(LBound(arr2d, 1) To UBound(arr2d, 1), LBound(arr2d, 2) To UBound(arr2d, 2) - targetIndexCount)
For j = LBound(arr2d, 2) To UBound(arr2d, 2)
If Not CollContainsKey(collkeys, "key" & CStr(j)) Then
For i = LBound(arr2d, 1) To UBound(arr2d, 1)
If IsObject(arr2d(i, j)) Then
Set result(i, j - offset) = arr2d(i, j)
Else
result(i, j - offset) = arr2d(i, j)
End If
Next
Else
offset = offset + 1
End If
Next
Array2DRemoveColIndex = result
Else
Array2DRemoveColIndex = VBA.Array()
End If
End Function
Public Function Filter2DArrayByRowIndexes(ByVal arr2d As Variant, ByVal indexes As Variant) As Variant()
' 二次元配列の行を引数で指定のインデックスの要素のみ取り出す、インデックスはindexesの要素順に取り出される
' indexesは配列またはコレクションで指定可
' 例:
' arr2d: [[1, 2], [3, 4], [5, 6], [7, 8]], indexes: [1, 3] -> [[3, 4], [7, 8]]
Dim item As Variant
Dim i As Long, j As Long
Dim index As Variant
Dim size As Long
Dim result() As Variant
If IsArray(indexes) Then
size = UBound(indexes) - LBound(indexes) + 1
Else
size = indexes.count
End If
ReDim result(LBound(arr2d, 1) To size + LBound(arr2d, 1) - 1, LBound(arr2d, 2) To UBound(arr2d, 2))
i = LBound(result, 1)
For Each index In indexes
For j = LBound(arr2d, 2) To UBound(arr2d, 2)
If IsObject(arr2d(index, j)) Then
Set result(i, j) = arr2d(index, j)
Else
result(i, j) = arr2d(index, j)
End If
Next
i = i + 1
Next
Filter2DArrayByRowIndexes = result
End Function
Public Function Filter2DArrayByColIndexes(ByVal arr2d As Variant, ByVal indexes As Variant) As Variant()
' 二次元配列の列を引数で指定のインデックスの要素のみ取り出す、インデックスはindexesの要素順に取り出される
' indexesは配列またはコレクションで指定可
' 例:
' arr2d: [[1, 2, 3, 4], [5, 6, 7, 8]], indexes: [1, 3] -> [[2, 4], [6, 8]]
Dim item As Variant
Dim i As Long, j As Long
Dim index As Variant
Dim size As Long
Dim result() As Variant
If IsArray(indexes) Then
size = UBound(indexes) - LBound(indexes) + 1
Else
size = indexes.count
End If
ReDim result(LBound(arr2d, 1) To UBound(arr2d, 1), LBound(arr2d, 2) To size + LBound(arr2d, 2) - 1)
j = LBound(result, 2)
For Each index In indexes
For i = LBound(arr2d, 1) To UBound(arr2d, 1)
If IsObject(arr2d(i, index)) Then
Set result(i, j) = arr2d(i, index)
Else
result(i, j) = arr2d(i, index)
End If
Next
j = j + 1
Next
Filter2DArrayByColIndexes = result
End Function
Public Sub ReplaceValueIn2DArray(ByRef arr2d As Variant, ByVal value As Variant, ByVal newValue As Variant)
' ReplaceValueInArrayの二次元配列版
' 依存する関数: IsStrictlyEqual
If Not IsArray(arr2d) Then Err.Raise Number:=13
Dim i As Long, j As Long
For i = LBound(arr2d, 1) To UBound(arr2d, 1)
For j = LBound(arr2d, 2) To UBound(arr2d, 2)
If IsStrictlyEqual(arr2d(i, j), value) Then
If IsObject(newValue) Then
Set arr2d(i, j) = newValue
Else
arr2d(i, j) = newValue
End If
End If
Next j
Next i
End Sub
Public Sub Paste2DArrayToCell(ByVal rngCell As Object, ByVal arr2d As Variant)
' 二次元配列をセルに貼り付け(Excel VBA専用)
' 使い方:
' Call Paste2DArrayToCell(ActiveSheet.Cells(1, 1), arr2d)
' 他のVBA(Access VBAなど)でエラーにならないように引数の型はRangeではなくObjectにしてある
rngCell.Resize(UBound(arr2d, 1) - LBound(arr2d, 1) + 1, UBound(arr2d, 2) - LBound(arr2d, 2) + 1).value = arr2d
End Sub
・ページ末尾
ジャンプ用の項目なので特に何も書きません