ArrayEditのまとめ

作成したArrayEditの「途中形態」が、時系列で次々と増えてきた。そこで、現時点の最終形をこちらに載せることにした。今後は、ここだけ更新することにする。

※結構なボリュームなので、畳んで置いておく。

↓ ScriptingRuntimeの参照設定を要す。

◆Seaquenceのソースコード（クリックで展開）◆

Option Explicit

' 取得する対象（フォルダ名か、ファイル名か）
    Public Enum ReturnGroup
        rgFolder
        rgFile
    End Enum

' 何に格納するか（配列か、コレクションか）
    Public Enum ReturnType
        rtArr
        rtCol
    End Enum

    Dim FSO As Scripting.FileSystemObject

Private Sub Class_Initialize()
    Set FSO = New Scripting.FileSystemObject
End Sub

'［用　途］
'   配列の指定インデックスの数を取得

Private Property Get ArrRowsAndColumnsCount(target_array As Variant, _
                                            rc_index As Long) As Long

    ArrRowsAndColumnsCount = UBound(target_array, rc_index) - LBound(target_array, rc_index) + 1
    
End Property

'［用　途］
'   配列の次元数取得
'
'［引　数］
'   arr As Variant  配列
'
'［戻り値］
'   正常終了    配列の次元数
'   -1の場合    異常終了　※つまり、arrは配列ではない

Private Function GetArrayDimension(arr As Variant) As Long
    
    If IsArray(arr) = False Then
        GetArrayDimension = -1
        Exit Function
    End If
    
    ' 配列の次元数を取得。
    
    Dim i As Long
    Dim TempNumber As Long
        
        On Error Resume Next
        Do While Err.Number = 0
            i = i + 1
            TempNumber = UBound(arr, i)
        Loop
        
        GetArrayDimension = i - 1

End Function

'［用　途］
'   指定セルに配列を貼り付ける。

'［引　数］
'   target_range As Range     配列を貼り付けるセル
'   source_array As Variant   貼り付けられる配列

'［戻り値］
'    0の場合    正常終了
'   -1の場合    異常終了　※target_arrayは配列ではない。
'   -2の場合    異常終了　※配列の次元数が３以上。

Function PasteArray(target_range As Range, _
                    source_array As Variant) As Long
    
    Dim r As Long     ' 貼り付ける行数
    Dim c As Long     ' 貼り付ける列数
    
    ' 配列の次元数取得
        PasteArray = GetArrayDimension(source_array)
        If PasteArray = -1 Then
            Exit Function
        Else
            Dim DimensionNumber As Long
                DimensionNumber = PasteArray
        End If
    
    ' 貼り付け行数の取得。
    Dim rMax As Long
        rMax = ArrRowsAndColumnsCount(source_array, 1)
    
        Select Case DimensionNumber
            
        ' 一次配列の場合。
            Case 1
                target_range.Resize(rMax) = WorksheetFunction.Transpose(source_array)
                
        ' 二次配列の場合。
            Case 2
                Dim cMax As Long
                    cMax = ArrRowsAndColumnsCount(source_array, 2)
                    target_range.Resize(rMax, cMax) = source_array
    
        ' 三次以上の場合。　※未対応。
            Case Else
                PasteArray = -2
        
        End Select

End Function

'［用　途］
'   指定範囲から、指定列番号のみ抽出した配列を作成
'   ※指定範囲は、配列を指定可能

'［引　数］
'   target_data          As Variant　抽出対象となる範囲
'   extract_column_array As Variant  抽出される列情報（配列）
'   例）1,3,5列目を抜き出す ⇒ extract_column_array = Array(1,3,5)
'       ※0列目を指定すると、空白列が挿入される。

'［戻り値］
'   配列の場合  正常終了
'   -1の場合    異常終了　extract_column_arrayの指定が不適切
'   -2の場合    異常終了　target_dataが範囲または配列以外
'   -3の場合    異常終了  抽出指定が元データの範囲を超えている

Public Function ExtractArray(target_data As Variant, _
                             extract_column_array As Variant) As Variant

    ' 抽出列の指定方法確認。
        If GetArrayDimension(extract_column_array) <> 1 Then
            ExtractArray = -1: Exit Function
        End If
    
    ' 抽出対象が範囲または配列以外の場合は処理中断。
        If TypeName(target_data) = "Range" Then
            If target_data.Rows.Count = 1 Or target_data.Columns.Count = 1 Then
                ExtractArray = target_data
                Exit Function
            End If
        ElseIf IsArray(target_data) = False Then
            ExtractArray = -2: Exit Function
        End If
        
    Dim DataArr As Variant
        DataArr = target_data
        
    ' 抽出列が抽出対象の範囲を超えている場合、処理を中断。
        If UBound(DataArr, 2) < extract_column_array(UBound(extract_column_array)) Then
            ExtractArray = -3: Exit Function
        End If
    
    ' 抽出後の配列定義。
    Dim rMax As Long
        rMax = ArrRowsAndColumnsCount(DataArr, 1)
    Dim cMax As Long
        cMax = ArrRowsAndColumnsCount(extract_column_array, 1)
    
    Dim TempArray As Variant
    ReDim TempArray(1 To rMax, 1 To cMax)
    
    ' 抽出後の配列作成。
    Dim r As Long
    Dim c As Long
    Dim i As Long
        i = 0
        For c = 1 To cMax
            For r = 1 To rMax
                If extract_column_array(i) > 0 Then
                    TempArray(r, c) = DataArr(r, extract_column_array(i))
                End If
            Next
            i = i + 1
        Next
                
        ExtractArray = TempArray

End Function

' source_array   抽出元の配列
' r_min         一次元要素の下限
' r_max         一次元要素の上限
' c_min         二次元要素の下限
' c_max         二次元要素の上限
' to_1d_flag    一次元または二次元の上限と下限が一致する場合、
'               抽出後の配列を一次元配列に変換するか否かのフラグ。
Function ExtractArray2(ByVal source_array As Variant, _
             Optional r_min As Long = -1, _
             Optional r_max As Long = -1, _
             Optional c_min As Long = -1, _
             Optional c_max As Long = -1, _
             Optional to_1d_flag As Boolean = True) As Variant
             
        ' 二次元配列であることの確認
        If GetArrayDimension(source_array) <> 2 Then
            ExtractArray2 = Array(): Exit Function
        End If
        
        ' 下限確認。
        ' 指定下限が無指定の場合、抽出元配列の下限を指定下限とする。
        ' ※指定下限が指定上限を上回る場合については、指定上限側で対処する。
        ' 指定下限が負の値の場合、指定下限を０とする。
        ' 指定下限が抽出元配列の下限を下回る場合、これを認める。
        If r_min = -1 Then
            r_min = LBound(source_array, 1)
        ElseIf r_min < 0 Then
            r_min = 0
        End If
        
        If c_min = -1 Then
            c_min = LBound(source_array, 2)
        ElseIf c_min < 0 Then
            c_min = 0
        End If
        
        ' 上限確認。
        ' 指定上限が無指定の場合、抽出元配列の上限を指定上限とする。
        ' 指定上限が指定下限を下回る場合、指定下限を指定上限とする。
        ' 指定上限が抽出元配列の上限を上回る場合、これを認める。
        If r_max = -1 Then
            r_max = UBound(source_array, 1)
        ElseIf r_max < r_min Then
            r_max = r_min
        End If
        
        If c_max = -1 Then
            c_max = UBound(source_array, 2)
        ElseIf c_max < c_min Then
            c_max = c_min
        End If
    
    ' 抽出用配列。
    Dim TempArray() As Variant
    ReDim TempArray(1 To r_max - r_min + 1, 1 To c_max - c_min + 1)
    
    Dim r As Long
    Dim c As Long
    
        ' 値抽出。
        For r = r_min To r_max
            For c = c_min To c_max
                On Error Resume Next
                TempArray(r - r_min + 1, c - c_min + 1) = source_array(r, c)
            Next
        Next
    
        ' １行または１列の配列の場合、二次元配列を一次元配列に変換。
        ' ※to_1d_flag = True の場合のみ
        If to_1d_flag Then
            If UBound(TempArray, 2) = 1 Then
                TempArray = WorksheetFunction.Transpose(TempArray)
            ElseIf UBound(TempArray, 1) = 1 Then
                TempArray = WorksheetFunction.Transpose(TempArray)
                TempArray = WorksheetFunction.Transpose(TempArray)
            End If
        End If

        ExtractArray2 = TempArray
End Function

Function ExtractArray3(source_array As Variant, ParamArray column_number())
    
    ' 抽出列数が無指定の場合、column_numberは空配列となる。
    ' この場合強制的に、1列目を抽出するものとする。
    If UBound(column_number) = -1 Then
        column_number = Array(1)
    End If
    
    Dim arr() As Variant
    ReDim arr(1 To UBound(source_array), 1 To UBound(column_number) + 1)
    
    ' 各行各列の値を一つずつ、新しい配列に格納する。
    Dim r As Long
    Dim c As Long
        For r = 1 To UBound(arr, 1)
            For c = 1 To UBound(arr, 2)
                arr(r, c) = WorksheetFunction.index(source_array, r, column_number(c - 1))
            Next
        Next
        
    ' 抽出後の配列が１列のみの場合、一次元配列に変換する。
        If UBound(arr, 2) = 1 Then
            arr = WorksheetFunction.Transpose(arr)
        End If
        
        ExtractArray3 = arr
End Function


'［用　途］
'   配列内に含まれる「指数」（例．0E000097）を文字列に変換

'［引　数］
'   arr As Variant　元の配列

'［戻り値］
'   指数を文字列に変換したあとの配列

Public Function ExponentialToString(arr As Variant) As Variant

    Dim myReg As RegExp
    Set myReg = New RegExp
        myReg.Pattern = "^\d+E\d+$"
        
    Dim rMin As Long: rMin = LBound(arr, 1)
    Dim rMax As Long: rMax = UBound(arr, 1)
    Dim cMin As Long: cMin = LBound(arr, 2)
    Dim cMax As Long: cMax = UBound(arr, 2)
    
    Dim r As Long, c As Long
    Dim TempArray As Variant
    ReDim TempArray(rMin To rMax, cMin To cMax)
        For r = rMin To rMax
            For c = cMin To cMax
                If myReg.test(arr(r, c)) = True Then
                    TempArray(r, c) = "'" & arr(r, c)
                Else
                    TempArray(r, c) = arr(r, c)
                End If
            Next
        Next
        
        ExponentialToString = TempArray

End Function

'［用　途］
'   二つの配列を結合する

'［引　数］
'   arr_1 As Variant　一つ目の配列
'   arr_2 As Vairant　二つ目の配列

'［戻り値］
'   arr_1 ⇒ arr_2 の順に結合した配列
'   ※インデックスは全て１始まりとする。

Public Function JoinArray(arr_1 As Variant, _
                          arr_2 As Variant, _
                 Optional join_direction As XlRowCol) As Variant
                
    On Error GoTo er1:
    
    Application.ScreenUpdating = False
    Dim Sh(1) As Worksheet
    Set Sh(0) = ActiveSheet
    
        Sheets.Add After:=Sheets(Sheets.Count)

    Set Sh(1) = ActiveSheet
    
        PasteArray Sh(1).Range("A1"), arr_1
    
    Dim PasteTarget As Range
        Select Case join_direction
            Case xlColumn
                Set PasteTarget = Sh(1).Cells(1, Sh(1).UsedRange.Columns.Count + 1)
            Case xlRows
                Set PasteTarget = Sh(1).Cells(Sh(1).UsedRange.Rows.Count + 1, 1)
        End Select
    
        PasteArray PasteTarget, arr_2
        
        JoinArray = Sh(1).UsedRange
        
    Application.DisplayAlerts = False
        Sh(1).Delete
    Application.DisplayAlerts = True
        Sh(0).Select
    
    Application.ScreenUpdating = True
    Exit Function
    
er1:
    Application.ScreenUpdating = True

End Function

'［用　途］
'   二次元配列について、一次元のサイズを変更する
Public Function SpecialRedim(ByVal arr As Variant, _
                             update_size As Long, _
                    Optional preserve_flag As Boolean = True) As Variant
    Dim TempArray() As Variant
    
        ' 最大次元であればRedimでサイズ変更可能なため、一旦行と列を入れ替える。
        TempArray = WorksheetFunction.Transpose(arr)
        
        ' サイズ変更。
        Select Case preserve_flag
            Case True
                ReDim Preserve TempArray(LBound(TempArray) To UBound(TempArray), _
                                         LBound(TempArray, 2) To update_size)
            Case False
                ReDim TempArray(LBound(TempArray) To UBound(TempArray), _
                                LBound(TempArray, 2) To update_size)
        End Select
        
        ' 再び行と列を入れ替え。
        SpecialRedim = WorksheetFunction.Transpose(TempArray)
End Function

'［用　途］
'   コレクションを一次元配列に変換する

'［引　数］
'   col as Collection   元データ
'

'［戻り値］
'   一次元配列

Public Function ToArray(col As Collection) As Variant

    Dim arr As Variant
    ReDim arr(col.Count - 1)
    Dim c As Variant
    Dim i As Long
        i = 0
        For Each c In col
            arr(i) = c
            i = i + 1
        Next
    
    ToArray = arr

End Function

'［用　途］
'   テーブルの任意の二列から、辞書（連想配列）を作成する。

'［引　数］
'   Tb As ListObject    辞書用テーブル
'   keyIndex As Variant キー列のラベル
'   itmIndex As Variant アイテム列のラベル

'［戻り値］
'   指定列で作成した辞書

'［備　考］
'   Microsoft Scripting Runtime 参照設定が必要（ファイル毎・初回のみ）

Function CreateDict(Tb As ListObject, _
                    keyIndex As Variant, _
                    itmIndex As Variant) As Dictionary
    
    Dim TempDict As Dictionary
    Set TempDict = New Dictionary
    
    Dim keyArr  As Variant
        keyArr = Tb.ListColumns(keyIndex).DataBodyRange
    Dim itmArr  As Variant
        itmArr = Tb.ListColumns(itmIndex).DataBodyRange
    
    Dim i As Long
    
    ' 各値を辞書にセット。
    For i = LBound(keyArr) To UBound(keyArr)
        TempDict(keyArr(i, 1)) = itmArr(i, 1)
    Next
    
    Set CreateDict = TempDict

End Function

'［用　途］
'   配列内にある指定値の数を数える

'［引　数］
'   arr As Variant              配列
'   specified_value As Variant  指定値

'［戻り値］
'   配列内に指定値が含まれる個数

'［備　考］
'   一次元配列でのみ有効

Function CountSpecifiedValueInArray(arr As Variant, _
                                    specified_value As Variant) As Long

    ' 配列の次元数確認。
    If GetArrayDimension(arr) <> 1 Then
        CountSpecifiedValueInArray = -1
        Exit Function
    End If
    
    Dim Counter As Long
        Counter = 0
    
    Dim s As Variant
        For Each s In arr
            If s = specified_value Then
                Counter = Counter + 1
            End If
        Next
        
        CountSpecifiedValueInArray = Counter

End Function

'［用　途］
'   配列内から空欄を除去

'［引　数］
'   arr As Variant 配列

'［戻り値］
'   空欄除去後の配列

'［備　考］
'   一次元配列でのみ有効

Function RemoveBlank(arr As Variant) As Variant
    
    ' 配列の次元数確認。
    If GetArrayDimension(arr) <> 1 Then Exit Function

    Dim TempCol As Collection
    Set TempCol = New Collection
    
    Dim iMin As Long
        iMin = LBound(arr)
    
    ' 空欄ではない要素のみでコレクションを作成する。
    Dim i As Long
        For i = iMin To UBound(arr)
            If arr(i) <> "" Then
                TempCol.Add arr(i)
            End If
        Next
        
    Dim iMax As Long
        iMax = TempCol.Count - iMin + 1
    
    Dim TempArray As Variant
    ReDim TempArray(iMin To iMax)
    
    Dim c As Variant
        i = iMin
        For Each c In TempCol
            TempArray(i) = c
            i = i + 1
        Next
        
        RemoveBlank = TempArray

End Function

'［用　途］
'   指定フォルダ下にあるフォルダ名やファイル名を取得

'［引　数］
'   folder_path As String       指定フォルダ
'   return_group As ReturnGroup 取得対象（フォルダ or ファイル）　※初期値：フォルダ
'   return_type As ReturnType   格納方法（配列 or コレクション）  ※初期値：配列

'［戻り値］
'   「フォルダまたはファイル」名称を格納した「配列またはコレクション」

'［備　考］
'   標準モジュールの列挙型（ReturnGroup および ReturnType）とセットで使用

Public Function GetFolderFileNames(folder_path As String, _
                          Optional return_group As ReturnGroup = rgFolder, _
                          Optional return_type As ReturnType = rtArr) As Variant
    Dim TempCol As Collection
    Set TempCol = New Collection

        ' 名称取得。
        Select Case return_group
            'フォルダの場合。
            Case rgFolder
                Dim myFolder As Folder
                For Each myFolder In FSO.GetFolder(folder_path).SubFolders
                    TempCol.Add myFolder.Name
                Next
            ' ファイルの場合。
            Case rgFile
                Dim myFile As File
                For Each myFile In FSO.GetFolder(folder_path).Files
                    TempCol.Add myFile.Name
                Next
        End Select

        ' 格納方法。
        Select Case return_type
            ' 配列の場合。
            Case rtArr
                GetFolderFileNames = ToArray(TempCol)
            ' コレクションの場合。
            Case rtCol
                Set GetFolderFileNames = TempCol
        End Select
End Function

'［用　途］
'   配列ソート

'［引　数］
'   arr As Variant          ソート前の配列
'   sort_type As SortOrder  昇順 or 降順　※初期値：昇順

'［戻り値］
'   ソート後の配列

Public Function SortArray(ByVal arr As Variant, _
                       Optional sort_order As Excel.XlSortOrder = xlAscending) As Variant
    Dim aryList As Object
    Dim s As Variant
    Set aryList = CreateObject("System.Collections.ArrayList")
    
    For Each s In arr
        Call aryList.Add(s)
    Next
    
    Select Case sort_order
        Case xlAscending
            ' 昇順でソート。
            Call aryList.Sort
        Case xlDescending
            ' 昇順でソートののち、降順へ反転。
            Call aryList.Sort
            Call aryList.Reverse
    End Select
    
    SortArray = aryList.ToArray
End Function

'［用　途］
'   二次元配列ソート

'［引　数］
'   arr As Variant          ソート前の配列
'   sort_column as long     ソートする列番号
'   sort_type As SortOrder  昇順 or 降順　※初期値：昇順

'［戻り値］
'   ソート後の配列

Public Function SortArray2D(ByVal arr As Variant, _
                         Optional sort_column As Long = 1, _
                         Optional sort_order As Excel.XlSortOrder = xlAscending) As Variant
    
    ' 各行要素を一次元配列として抽出し、ソートしたい列の値を付して「,」で結合。
    ' これらで構成された一次元を作成する。
    ' ※列のデータを、一番左のセルにギュッと寄せて、ソートしたい列の値を先頭に付すイメージ。
    Dim TempArray() As Variant
    ReDim TempArray(LBound(arr) To UBound(arr))
    Dim RowArray As Variant
    Dim i As Long
        For i = LBound(arr) To UBound(arr)
            RowArray = ExtractArray2(arr, i, i)
            TempArray(i) = arr(i, sort_column) & "," & Join(RowArray, ",")
        Next
    
    ' 一次元配列としてソート。
        TempArray = SortArray(TempArray, sort_order)
    
    ' ソートした結果を再び分割し、新たな配列に振りなおす。
    Dim DestinationArray() As Variant
    ReDim DestinationArray(LBound(arr) To UBound(arr), LBound(arr, 2) To UBound(arr, 2))
    Dim j As Long
        For i = LBound(TempArray) To UBound(TempArray)
            RowArray = Split(TempArray(i), ",")
            
            ' ０番目の要素はソート用であるため不要 ⇒ １番目からループ。
            For j = 1 To UBound(RowArray)
                DestinationArray(LBound(arr) + i, LBound(arr) + j - 1) = RowArray(j)
            Next
        Next
        
        SortArray2D = DestinationArray
        
End Function


'［用　途］
'   配列内の指定値を数える。

'［引　数］
'   val As Variant  数えたい値
'   arr As Variant  対象となる配列

'［戻り値］
'   配列内にある指定値の個数。

Public Function CountInArr(val As Variant, _
                           arr As Variant) As Long
    Dim s As Variant
    Dim i As Long
        i = 0
        For Each s In arr
            If s = val Then
                i = i + 1
            End If
        Next
        
        CountInArr = i
End Function

'［用　途］
'   任意の値のみで構成された配列を作成する。

'［引　数］
'   content       配列に詰め込む値
'   count_up      詰め込む値をカウントアップするか否か
'   count_number  １回のカウントアップ量
'   l_bound       インデックス番号の最小値
'   u_bound       インデックス番号の最大値

'［戻り値］
'   任意の値のみで構成された配列。

Function DenseArray(content As Variant, _
                    Optional count_up As Boolean = False, _
                    Optional count_number As Long = 1, _
                    Optional l_bound As Long = 0, _
                    Optional u_bound As Long = 10) As Variant
          
    Dim arr() As Variant
    ReDim arr(l_bound To u_bound)
    Dim i As Long
        For i = l_bound To u_bound
            If count_up Then
                
                ' 数値でなければカウントアップできないので、ここで判別。
                If IsNumeric(content) Then
                    arr(i) = content + (i - 1) * count_number
                Else
                    arr(i) = content
                End If
            Else
                arr(i) = content
            End If
        Next
        DenseArray = arr
End Function

'［用　途］
'   内包判定。

'［引　数］
'   target_range1　内包される側
'   target_range2　内包する側

'［戻り値］
'   target_range1 が、完全にtarget_range2 の内側にある ⇒ True
'   それ以外の場合 ⇒ False

Function OverlapConfirmation(target_range1 As Range, _
                             target_range2 As Range) As Boolean
    Dim Result As Range
    Set Result = Union(target_range1, target_range2)
        ' Unionメソッドの結果がtarget_range2と同じならば、
        If Result.Address = target_range2.Address Then
            ' target_range1はtarget_range2に内包されている。
            OverlapConfirmation2 = True
        End If
End Function

'［用　途］
'   指定範囲のうち、非表示を無視して配列を作成。

'［引　数］
'   target_range    指定範囲

'［戻り値］
'   指定範囲のうち、非表示内容を含まない配列。

Function GetArrayFromVisibleRange(target_range As Range) As Variant
    Dim arr() As Variant
        arr = target_range
    Dim col As Collection
    Set col = New Collection
    Dim i As Long
        For i = 1 To target_range.Columns.Count
            If target_range.Columns(i).Hidden = False Then
                col.Add i
            End If
        Next

        arr = ExtractArray(arr, ToArray(col))

        GetArrayFromVisibleRange = arr
End Function

' Excel2019から実装されるTextJoin関数の再現版。
Function Text_Join(delimiter As String, _
                   ignore_blank As Boolean, _
                   rng1 As Range, _
                   ParamArray additional_range()) As String

    Dim col As Collection
    Set col = New Collection
    Dim i As Long

    ' 一つ目の指定範囲にある各セルの値をコレクションに格納。
        For i = 1 To rng1.Count
            col.Add rng1.Item(i).Value
        Next

    ' 二つ目以降の指定範囲があれば、各範囲・各セルの値を
    ' コレクションに格納。
    Dim tempRange As Variant
        For Each tempRange In additional_range
            For i = 1 To tempRange.Count
                col.Add tempRange.Item(i).Value
            Next
        Next

    ' 空白を無視する場合、コレクションからEmptyを除去。
    If ignore_blank = True Then
        For i = col.Count To 1 Step -1
            If IsEmpty(col.Item(i)) = True Then
                col.Remove (i)
            End If
        Next
    End If

    ' コレクションを一旦配列にしたうえで結合。
    Dim arr As Variant
    ReDim arr(1 To col.Count)
        For i = 1 To col.Count
            arr(i) = col.Item(i)
        Next

        Text_Join = Join(arr, delimiter)
End Function

' ワークシート上でスプリット関数を使用するためのユーザー定義関数。
Function SubSplit(expression As String, _
         Optional delimiter As String = ",", _
         Optional ByVal index As Long = 0) As String

    Dim arr As Variant
        arr = Split(expression, delimiter)

        ' 配列が０始まりのため。
        index = index - 1

        If UBound(arr) < index Then
            SubSplit = "要素の上限を上回っています。"
        ElseIf index = -1 Then
            SubSplit = UBound(arr) + 1
        ElseIf index < -1 Then
            SubSplit = "要素の下限を下回っています。"
        Else
            SubSplit = arr(index)
        End If
End Function

' 配列、範囲、テーブルから重複の無い一次元配列を作成。
Function RemovalDuplicateArray(ByVal source As Variant, _
                      Optional ByVal target_column_index As Variant = 1) As Variant
                      
    ' 配列確認。
    Dim source_array As Variant

    ' 配列に格納できないものがセットされる場合を想定し、一時的にエラーを無視。
        On Error Resume Next
        
    ' sourceを範囲で指定された場合。
        If TypeName(source) = "Range" Then
        ' 列番号がアルファベットで指定された場合、数値に変換する。
            If IsNumeric(target_column_index) = False Then
                target_column_index = StrConv(target_column_index, vbNarrow + vbUpperCase)
                If target_column_index Like "*[A-Z]*" Then
                    target_column_index = Cells(1, target_column_index).Column
                End If
                source_array = source.Value
            End If
        
    ' sourceがテーブルの場合。
        ElseIf TypeName(source) = "ListObject" Then
            source_array = source.DataBodyRange.Value
        ' 列がラベル名で指定されている場合、列番号に置き換える。
            If IsNumeric(target_column_index) = False Then
                target_column_index = source.ListColumns(target_column_index).index
            End If
            
    ' sourceが配列の場合。
        ElseIf IsArray(source) Then
            source_array = source

    ' sourceが上記以外の場合（例えば文字列などの場合）。
        Else
            source_array = Array(source)
        End If
    
    ' 上記でエラーが発生していた場合の処理。
        If Err.Number <> 0 Then
            GoTo er:
        Else
            On Error GoTo 0
        End If
    
    ' 配列の次元数を確認。
    Dim DimensionNumber As Long
        DimensionNumber = GetArrayDimension(source_array)
    
    ' 作業用配列。
    Dim TempArray As Variant
        Select Case DimensionNumber
        ' 一次元配列の場合。
            Case 1
                TempArray = source_array
        ' 二次元配列の場合、目的列を抜き出し。
            Case 2
                TempArray = WorksheetFunction.index(source_array, 0, target_column_index)
        ' 三次元以上は対応しない。
            Case Else
                GoTo er:
        End Select
                      
    ' 重複除去用の辞書（連想配列）
    Dim Dict As Object
    Set Dict = CreateObject("Scripting.Dictionary")
    Dim a As Variant
        For Each a In TempArray
            ' 配列内の各値を、辞書に格納する。
            ' 重複除去が目的のため、itemは不問。今回は「1」とした。
            ' ※空欄はリストに含めない。
            If a <> vbNullString Then
                Dict(a) = 1
            End If
        Next
        ' 辞書のkeyが、重複除去後の配列として取り出せる。
        RemovalDuplicateArray = Dict.Keys
        
        Exit Function
er:
    RemovalDuplicateArray = Array()
    On Error GoTo 0
End Function

Public Function TargetArray(SourceArray As Variant) As ArrayEdit
    Set TargetArray = New ArrayEdit
        TargetArray.source_array = SourceArray
End Function

◆ArrayEditのソースコード（クリックで展開）◆

Option Explicit

' 二次元配列編集用。
' 以下、シートイメージに準えて、
' 一次元目を行、二次元目を列と
' 表記している。

' 編集前の配列。
Public source_array As Variant
' 編集後の配列　※編集結果
Public edited_array As Variant
' 編集前の配列から編集後の配列を差し引いたもの
' 例）RowFilterでDeleteを選択したならば、Remain側がこちらに格納される。
Public invers_array As Variant

' 仮置用配列。
Dim TempArray As Variant
' ループ用変数：行
Dim r As Long
' ループ用変数：列
Dim c As Long
' ループ用変数：カウントアップ用（行と列併用）
Dim i As Long
Dim j As Long
' 編集内容の選択肢
Enum ProcessIndex
    ' 削除
    piDelete = -1
    ' 空白
    piBlank
    ' 空白挿入
    piInsert
End Enum
' カット＆ペーストの貼り付け選択肢
Enum CutAndPasteResult
    cpInsert
    cpOverWrite
End Enum
' フィルターで消すか残すかの選択肢
Enum RemainOrDelete
    rdRemain
    rdDelete
End Enum
' 大小比較用
Enum HighOrLow
    hlMore  ' 以上
    hlLess  ' 以下
    hlAbobe ' 超
    hlBelow ' 未満
End Enum
' シートへの貼り付け
Enum PasteType
    ptRange
    ptTable
End Enum

' 三種類の配列のどれを使用するか選択
Enum SelectArray
    case_source ' 元の配列
    case_edited ' 編集後の配列
    case_invers ' 元の配列から編集後の配列を差し引いたもの
End Enum

Private Sub Class_Initialize()
    source_array = Array()
    edited_array = Array()
    invers_array = Array()
    SetPersonalTableStyle
End Sub

' 作業結果の仮置用
Private Function GetTempArray(Optional select_array As SelectArray = case_source) As Variant
    Select Case select_array
        Case SelectArray.case_source
            GetTempArray = source_array
        Case SelectArray.case_edited
            GetTempArray = edited_array
        Case SelectArray.case_invers
            GetTempArray = invers_array
    End Select
    If UBound(GetTempArray) = -1 Then
        GetTempArray = source_array
    End If
End Function

' 行編集。
Private Function RowEdit(row_index As Long, _
                         p_index As ProcessIndex, _
                Optional row_shift As Excel.XlDirection = xlDown, _
                Optional select_array As SelectArray = case_source) As Variant
                
    ' 編集前配列。
        TempArray = GetTempArray(select_array)

    ' 変更後の最大行数算出。
    Dim TempMax As Long
        TempMax = rMax + p_index + dr(row_shift)
    
    ' 編集後の配列（仮置用）
    Dim arr() As Variant
    ReDim arr(rMin To TempMax, cMin To cMax)
        i = rMin
        For r = rMin To TempMax
            
            If i = row_index Then
                ' 削除または挿入によって、ループ変数を先送り
                ' （つまり一つ飛ばし）している。
                Select Case p_index
                    Case piDelete
                        i = i - p_index
                    Case piInsert
                        r = r + p_index
                End Select
            End If
            
            On Error Resume Next
            For c = cMin To cMax
                arr(r, c) = TempArray(i, c)
            Next
            On Error GoTo 0
            i = i + 1
        Next
        RowEdit = arr
End Function

' row_index 行目を削除。
Public Function RowDelete(row_index As Long, _
                 Optional select_array As SelectArray = case_source) As Variant
    RowDelete = RowEdit(row_index, piDelete, , select_array)
    edited_array = RowDelete
    invers_array = Array()
End Function

' row_index 行目に空白挿入。
Public Function RowInsertBlank(ByVal row_index As Long, _
                 Optional row_shift As Excel.XlDirection = xlDown, _
                 Optional select_array As SelectArray = case_source) As Variant
    
' 右と左へのシフトは無視。
    row_index = row_index + dr(row_shift)
    RowInsertBlank = RowEdit(row_index, piInsert, row_shift, select_array)
    edited_array = RowInsertBlank
    invers_array = Array()
End Function

' row_index 行目を空白化。
Public Function RowBlank(row_index As Long, _
                Optional select_array As SelectArray = case_source) As Variant
    ' 指定行を削除
    RowDelete row_index, select_array
    ' 指定行に空白を挿入
    RowBlank = RowInsertBlank(row_index, , case_edited)
    edited_array = RowBlank
    invers_array = Array()
End Function

' カット＆ペースト
Public Function RowCutAndPaste(ByVal source_row_index As Long, _
                               ByVal destination_row_index As Long, _
                      Optional cut_or_copy As Excel.XlCutCopyMode = xlCut, _
                      Optional overwrite_or_insert As CutAndPasteResult = cpOverWrite, _
                      Optional row_shift As Excel.XlDirection = xlDown, _
                      Optional select_array As SelectArray = case_source) As Variant
                      
    ' 貼り付け 又は 挿入行。
    Dim arr As Variant
        TempArray = GetTempArray(select_array)
        arr = WorksheetFunction.index(TempArray, source_row_index, 0)
                     
    ' カットなら行削除。
        If cut_or_copy = xlCut Then
            RowDelete source_row_index, select_array
            
            ' 貼り付けまたは挿入先がカット行より下なら、１行繰り上がり。
            If source_row_index < destination_row_index Then
                destination_row_index = destination_row_index - 1
            End If
        End If
    
    ' 挿入なら空白挿入。
        If overwrite_or_insert = cpInsert Then
            If row_shift = xlUp Then
                destination_row_index = destination_row_index + 1
            End If
            
            If cut_or_copy = xlCopy Then
                RowInsertBlank destination_row_index, xlDown, select_array
            Else
                RowInsertBlank destination_row_index, xlDown, case_edited
            End If
        End If
        
    ' 貼り付け または 挿入。
        If cut_or_copy = xlCopy And overwrite_or_insert = cpOverWrite Then
            edited_array = TempArray
        End If
        For c = cMin To cMax
            edited_array(destination_row_index, c) = arr(c)
        Next
        
        RowCutAndPaste = edited_array
        edited_array = RowCutAndPaste
        invers_array = Array()
End Function


' 行の入れ替え
Public Function RowExchange(row_index_1 As Long, _
                            row_index_2 As Long, _
                   Optional select_array As SelectArray = case_source) As Variant
    Dim r_low As Long
        r_low = WorksheetFunction.Min(row_index_1, row_index_2)
    Dim r_high As Long
        r_high = WorksheetFunction.Max(row_index_1, row_index_2)
        
        RowCutAndPaste r_high, r_low, xlCut, cpInsert, xlDown, select_array
        If r_low + 1 <> r_high Then
            RowExchange = RowCutAndPaste(r_low + 1, r_high, xlCut, cpInsert, xlUp, case_edited)
        Else
            RowExchange = edited_array
        End If
        edited_array = RowExchange
        invers_array = Array()
End Function

' 行のフィルター抽出
' 初期設定：① 完全一致，②ヘッダーを含めない，③指定文字を消す
Public Function RowFilter(filt As Variant, _
                          column_index As Long, _
                Optional rf_LookAt As Excel.XlLookAt = xlWhole, _
                Optional rf_header As Excel.XlYesNoGuess = xlYes, _
                Optional rf_result As RemainOrDelete = RemainOrDelete.rdDelete, _
                Optional select_array As SelectArray = case_source) As Variant
                
    ' 元の配列
        TempArray = GetTempArray(select_array)
    
    ' 仮置用：残す場合。
    Dim TempArray_Remain As Variant
    ReDim TempArray_Remain(rMin To rMax, cMin To cMax)
    
    ' 仮置用：消す場合。
    Dim TempArray_Delete As Variant
    ReDim TempArray_Delete(rMin To rMax, cMin To cMax)
    
    ' 一行目をヘッダーと見なす場合(xlYes）、強制的に配列の一行目に組み込む。
    Dim StartRowIndex As Long
        If rf_header = xlYes Then
            For c = cMin To cMax
                TempArray_Remain(rMin, c) = TempArray(rMin, c)
                TempArray_Delete(rMin, c) = TempArray(rMin, c)
            Next
            StartRowIndex = rMin + 1
        Else
            StartRowIndex = rMin
        End If
    
    Dim arr As Variant
        If IsArray(filt) Then
            arr = filt
        Else
            arr = Array(filt)
        End If
    
    ' フィルター。
    Dim iR As Long
    Dim iD As Long
        iR = StartRowIndex
        iD = StartRowIndex
    
    Dim LoopIndex As Variant
    Dim LoopFlag As Boolean
        
        For r = StartRowIndex To rMax
            
            LoopFlag = False
            
            For Each LoopIndex In arr

                ' 部分一致と完全一致の確認。
                If rf_LookAt = xlPart Then
                    LoopIndex = "*" & LoopIndex & "*"
                End If
            
                ' 残した結果の配列。
                If TempArray(r, column_index) Like LoopIndex Then
                    For c = cMin To cMax
                        TempArray_Remain(iR, c) = TempArray(r, c)
                    Next
                    iR = iR + 1
                    LoopFlag = True
                    Exit For
                End If
            Next
            
            ' 消す結果の配列。
            If LoopFlag = False Then
                For c = cMin To cMax
                    TempArray_Delete(iD, c) = TempArray(r, c)
                Next
                iD = iD + 1
            End If
        Next
    
    ' 消すか残すか、指定された側をセット。
        Select Case rf_result
            Case RemainOrDelete.rdDelete
                edited_array = SpecialRedim(TempArray_Delete, iD - 1)
                invers_array = SpecialRedim(TempArray_Remain, iR - 1)
            Case RemainOrDelete.rdRemain
                edited_array = SpecialRedim(TempArray_Remain, iR - 1)
                invers_array = SpecialRedim(TempArray_Delete, iD - 1)
        End Select
           
        RowFilter = edited_array
End Function

' 行フィルター抽出の正規表現版
Public Function RowRegExpFilter(filt_pattern As Variant, _
                                column_index As Long, _
                       Optional rf_header As Excel.XlYesNoGuess = xlYes, _
                       Optional rf_result As RemainOrDelete = RemainOrDelete.rdDelete, _
                       Optional select_array As SelectArray = case_source) As Variant

    ' 元の配列
        TempArray = GetTempArray(select_array)

    ' 仮置用：残す場合。
    Dim TempArray_Remain As Variant
    ReDim TempArray_Remain(rMin To rMax, cMin To cMax)
    
    ' 仮置用：消す場合。
    Dim TempArray_Delete As Variant
    ReDim TempArray_Delete(rMin To rMax, cMin To cMax)

    ' 一行目をヘッダーと見なす場合(xlYes）、強制的に配列の一行目に組み込む。
    Dim StartRowIndex As Long
        If rf_header = xlYes Then
            For c = cMin To cMax
                TempArray_Remain(rMin, c) = TempArray(rMin, c)
                TempArray_Delete(rMin, c) = TempArray(rMin, c)
            Next
            StartRowIndex = rMin + 1
        Else
            StartRowIndex = rMin
        End If

    ' 正規表現の設定。
    Dim myReg As Object
    Set myReg = CreateObject("VBScript.RegExp")
        myReg.IgnoreCase = False
        myReg.Pattern = filt_pattern
    
    ' フィルター。
    Dim iR As Long
    Dim iD As Long
        iR = StartRowIndex
        iD = StartRowIndex
        For r = StartRowIndex To rMax
            
            ' 消した結果の配列。
            If myReg.test(TempArray(r, column_index)) = False Then
                For c = cMin To cMax
                    TempArray_Delete(iD, c) = TempArray(r, c)
                Next
                iD = iD + 1
            
            ' 残した結果の配列。
            Else
                For c = cMin To cMax
                    TempArray_Remain(iR, c) = TempArray(r, c)
                Next
                iR = iR + 1
            End If
        Next
    
    ' 消すか残すか、指定された側をセット。
        Select Case rf_result
            Case RemainOrDelete.rdDelete
                edited_array = SpecialRedim(TempArray_Delete, iD - 1)
                invers_array = SpecialRedim(TempArray_Remain, iR - 1)
            Case RemainOrDelete.rdRemain
                edited_array = SpecialRedim(TempArray_Remain, iR - 1)
                invers_array = SpecialRedim(TempArray_Delete, iD - 1)
        End Select
        
        RowRegExpFilter = edited_array
End Function

' 行フィルター抽出の数量比較版
Public Function RowNumericFilter(filt As Variant, _
                                 column_index As Long, _
                        Optional rf_type As HighOrLow = HighOrLow.hlMore, _
                        Optional rf_header As Excel.XlYesNoGuess = xlYes, _
                        Optional rf_result As RemainOrDelete = RemainOrDelete.rdDelete, _
                        Optional select_array As SelectArray = case_source) As Variant
        
    ' 数値または日付にのみ対応。
        If Not IsNumeric(filt) And Not IsDate(filt) Then
            RowNumericFilter = GetTempArray(select_array)
            Exit Function
        End If

    ' 元の配列
        TempArray = GetTempArray(select_array)
    
    ' 仮置用：残す場合。
    Dim TempArray_Remain As Variant
    ReDim TempArray_Remain(rMin To rMax, cMin To cMax)
    
    ' 仮置用：消す場合。
    Dim TempArray_Delete As Variant
    ReDim TempArray_Delete(rMin To rMax, cMin To cMax)
    
    ' 一行目をヘッダーと見なす場合(xlYes）、強制的に配列の一行目に組み込む。
    Dim StartRowIndex As Long
        If rf_header = xlYes Then
            For c = cMin To cMax
                TempArray_Remain(rMin, c) = TempArray(rMin, c)
                TempArray_Delete(rMin, c) = TempArray(rMin, c)
            Next
            StartRowIndex = rMin + 1
        Else
            StartRowIndex = rMin
        End If
    
    ' フィルター。
    Dim iR As Long
    Dim iD As Long
        iR = StartRowIndex
        iD = StartRowIndex
        
        For r = StartRowIndex To rMax
            
            ' 残した結果の配列。
            If CompareResultFlag(source_array(r, column_index), filt, rf_type, rf_result) Then
                For c = cMin To cMax
                    TempArray_Remain(iR, c) = TempArray(r, c)
                Next
                iR = iR + 1
            Else
            
            ' 消す結果の配列。
                For c = cMin To cMax
                    TempArray_Delete(iD, c) = TempArray(r, c)
                Next
                iD = iD + 1
            End If
        Next
    
    ' 消すものと残すものをそれぞれセット。
        edited_array = SpecialRedim(TempArray_Remain, iR - 1)
        invers_array = SpecialRedim(TempArray_Delete, iD - 1)
           
        RowNumericFilter = edited_array
End Function

Private Function CompareResultFlag(ByVal val1 As Variant, _
                                   ByVal val2 As Variant, _
                                   rf_type As HighOrLow, _
                                   rf_result As RemainOrDelete) As Boolean
    
    If IsNumeric(val1) Then
        val1 = CDbl(val1)
        val2 = CDbl(val2)
    ElseIf IsDate(CDate(val1)) Then
        val1 = CDate(val1)
        val2 = CDate(val2)
    End If

    ' 初期値。
    CompareResultFlag = False
    
    ' 大小比較。
    Select Case rf_result
        ' 残す場合。
        Case RemainOrDelete.rdRemain
            Select Case rf_type
                ' 以上の場合。
                Case HighOrLow.hlMore
                    If val1 >= val2 Then CompareResultFlag = True
                ' 超える場合。
                Case HighOrLow.hlAbobe
                    If val1 > val2 Then CompareResultFlag = True
                ' 以下の場合。
                Case HighOrLow.hlLess
                    If val1 <= val2 Then CompareResultFlag = True
                ' 未満の場合。
                Case HighOrLow.hlBelow
                    If val1 < val2 Then CompareResultFlag = True
            End Select
        
        
        ' 消す場合。※残す場合と逆の条件になる。
        Case RemainOrDelete.rdDelete
            Select Case rf_type
                ' 以上の場合。
                Case HighOrLow.hlMore
                    If val1 < val2 Then CompareResultFlag = True
                ' 超える場合。
                Case HighOrLow.hlAbobe
                    If val1 <= val2 Then CompareResultFlag = True
                ' 以下の場合。
                Case HighOrLow.hlLess
                    If val1 > val2 Then CompareResultFlag = True
                ' 未満の場合。
                Case HighOrLow.hlBelow
                    If val1 >= val2 Then CompareResultFlag = True
            End Select
    End Select
            
End Function

' レコード追加。
Public Function RowAdd(arr As Variant, _
              Optional target_row_index As Long, _
              Optional overwrite_or_insert As CutAndPasteResult = cpOverWrite, _
              Optional select_array As SelectArray = case_source) As Variant
    
    ' 追加する配列は、１次元配列または２次元配列のうち１次元要素が１つに限る。
        If GetArrayDimension(arr) = 2 Then
            arr = WorksheetFunction.Transpose(WorksheetFunction.Transpose(arr))
        End If
        ReDim Preserve arr(1 To UBound(arr) - LBound(arr) + 1)
        
        TempArray = GetTempArray(select_array)
    
    ' 追加用に行を拡張。
        If overwrite_or_insert = cpInsert Then
            TempArray = SpecialRedim(TempArray, rMax + 1)
            edited_array = TempArray
            If target_row_index <> 0 Then
                RowCutAndPaste rMax, target_row_index, xlCut, cpInsert, xlDown, case_edited
                TempArray = edited_array
            Else
                target_row_index = rMax
            End If
        End If
    
    Dim a As Variant
    Dim i As Long: i = cMin
        For Each a In arr
            TempArray(target_row_index, i) = arr(i)
            If i = cMax Then
                Exit For
            Else
                i = i + 1
            End If
        Next
        
        RowAdd = TempArray
        edited_array = RowAdd
        invers_array = Array()
End Function

' シフトの方向による、挿入対象列との差分を求める。
' xlDown ・・・０
' xlUp　 ・・・１
Private Function dr(row_shift As Excel.XlDirection) As Long
    If row_shift <> xlToLeft And row_shift <> xlToRight Then
        dr = (xlDown - row_shift) / (xlDown - xlUp)
    End If
End Function

' *******************************************************************************
' 列編集。
Private Function ColumnEdit(column_index As Long, _
                            p_index As ProcessIndex, _
                   Optional column_shift As Excel.XlDirection = xlToRight, _
                   Optional select_array As SelectArray = case_source) As Variant
                
    ' 編集前配列。
        TempArray = GetTempArray(select_array)
                
    ' 変更後の最大列数算出。
    Dim TempMax As Long
        TempMax = cMax + p_index + dc(column_shift)
    
    ' 編集後の配列（仮置用）
    Dim arr() As Variant
    ReDim arr(rMin To rMax, cMin To TempMax)
        i = cMin
        For c = cMin To TempMax
            
            If i = column_index Then
                ' 削除または挿入によって、ループ変数を先送り
                ' （つまり一つ飛ばし）している。
                Select Case p_index
                    Case piDelete
                        i = i - p_index
                    Case piInsert
                        c = c + p_index
                End Select
            End If
            
            On Error Resume Next
            For r = rMin To rMax
                arr(r, c) = TempArray(r, i)
            Next
            On Error GoTo 0
            i = i + 1
        Next
        ColumnEdit = arr
End Function

' column_index 列目を削除。
Public Function ColumnDelete(column_index As Long, _
                    Optional select_array As SelectArray = case_source) As Variant
    ColumnDelete = ColumnEdit(column_index, piDelete, , select_array)
    edited_array = ColumnDelete
    invers_array = Array()
End Function

' column_index 列目に空白挿入。
Public Function ColumnInsertBlank(ByVal column_index As Long, _
                    Optional column_shift As Excel.XlDirection = xlToRight, _
                    Optional select_array As SelectArray = case_source) As Variant
    ' 上と下へのシフトは無視。
    column_index = column_index + dc(column_shift)
    ColumnInsertBlank = ColumnEdit(column_index, piInsert, column_shift, select_array)
    edited_array = ColumnInsertBlank
    invers_array = Array()
End Function

' column_index 列目を空白化。
Public Function ColumnBlank(column_index As Long, _
                   Optional select_array As SelectArray = case_source) As Variant
    ' 指定行を削除
    ColumnDelete column_index, select_array
    ' 指定行に空白を挿入
    ColumnBlank = ColumnInsertBlank(column_index, , case_edited)
    edited_array = ColumnBlank
    invers_array = Array()
End Function

' カット＆ペースト
Public Function ColumnCutAndPaste(ByVal source_column_index As Long, _
                                  ByVal destination_column_index As Long, _
                         Optional cut_or_copy As Excel.XlCutCopyMode = xlCut, _
                         Optional overwrite_or_insert As CutAndPasteResult = cpOverWrite, _
                         Optional column_shift As Excel.XlDirection = xlToRight, _
                         Optional select_array As SelectArray = case_source) As Variant
                       
    ' 貼り付け 又は 挿入列。
    Dim arr As Variant
        TempArray = GetTempArray(select_array)
        arr = WorksheetFunction.Transpose(WorksheetFunction.index(TempArray, 0, source_column_index))
               
    ' カットなら列削除。
        If cut_or_copy = xlCut Then
            ColumnDelete source_column_index, select_array
            
            ' 貼り付けまたは挿入先がカット列より右なら、１列繰り上がり。
            If source_column_index < destination_column_index Then
                destination_column_index = destination_column_index - 1
            End If
        End If
               
    ' 挿入なら空白挿入。
        If overwrite_or_insert = cpInsert Then
            If column_shift = xlToLeft Then
                destination_column_index = destination_column_index + 1
            End If
            
            If cut_or_copy = xlCopy Then
                ColumnInsertBlank destination_column_index, xlToRight, select_array
            Else
                ColumnInsertBlank destination_column_index, xlToRight, case_edited
            End If
        End If
               
    ' 貼り付け または 挿入。
        If cut_or_copy = xlCopy And overwrite_or_insert = cpOverWrite Then
            edited_array = TempArray
        End If
        For r = rMin To rMax
            edited_array(r, destination_column_index) = arr(r)
        Next
        
        ColumnCutAndPaste = edited_array
        edited_array = ColumnCutAndPaste
        invers_array = Array()
End Function

' 列の入れ替え
Public Function ColumnExchange(column_index_1 As Long, _
                               column_index_2 As Long, _
                      Optional select_array As SelectArray = case_source) As Variant
    Dim c_low As Long
        c_low = WorksheetFunction.Min(column_index_1, column_index_2)
    Dim c_high As Long
        c_high = WorksheetFunction.Max(column_index_1, column_index_2)
        
        ColumnCutAndPaste c_high, c_low, xlCut, cpInsert, xlToRight, select_array
        If c_low + 1 <> c_high Then
            ColumnExchange = ColumnCutAndPaste(c_low + 1, c_high, xlCut, cpInsert, xlToLeft, case_edited)
        Else
            ColumnExchange = edited_array
        End If
        edited_array = ColumnExchange
        invers_array = Array()
End Function

' シフトの方向による、挿入対象列との差分を求める。
' xlToRight・・・０
' xlToLeft ・・・１
Private Function dc(column_shift As Excel.XlDirection) As Long
    If column_shift <> xlUp And column_shift <> xlDown Then
        dc = (xlToRight - column_shift) / (xlToRight - xlToLeft)
    End If
End Function

' レコード追加。
Public Function ColumnAdd(arr As Variant, _
                Optional target_column_index As Long, _
                Optional overwrite_or_insert As CutAndPasteResult = cpOverWrite, _
                Optional select_array As SelectArray = case_source) As Variant
    
    ' 追加する配列は、１次元配列または２次元配列のうち１次元要素が１つに限る。
        arr = WorksheetFunction.Transpose(WorksheetFunction.Transpose(arr))
        If GetArrayDimension(arr) = 2 Then
            Exit Function
        End If
        
        TempArray = GetTempArray(select_array)
        
    ' 追加用に列を拡張。
        If overwrite_or_insert = cpInsert Then
            ReDim Preserve TempArray(rMin To rMax, cMin To cMax + 1)
            edited_array = TempArray
            If target_column_index <> 0 Then
                ColumnCutAndPaste cMax, target_column_index, xlCut, cpInsert, xlToRight, case_edited
                TempArray = edited_array
            Else
                target_column_index = cMax
            End If
        End If
    
    Dim a As Variant
    Dim i As Long: i = rMin
        For Each a In arr
            TempArray(i, target_column_index) = arr(i)
            If i = cMax Then
                Exit For
            Else
                i = i + 1
            End If
        Next
        
        ColumnAdd = TempArray
        edited_array = ColumnAdd
        invers_array = Array()
End Function

' destination As String 貼り付け先アドレス　例．A1
' sheet_name As String　貼り付け先シート名
'   無指定の場合・・・ActiveSheet
'   既存名を指定・・・指定名のシート
'   指定名が無い・・・指定名で新規シートを作成
' copy_sheet As Boolean 指定シートをコピーしたうえで貼り付けるか
' new _name As String コピーしたシートの名前
'   無指定の場合・・・Excelがコピーした際につけた名前のままとなる
' paste_type as PasteType テータまたはテーブルを選択
' column_autofit As Boolean 貼り付け後の列幅自動調整
' 配列をシートへ貼り付け。
Public Function PasteArray(Optional destination As String = "A1", _
                           Optional sheet_name As String = vbNullString, _
                           Optional copy_sheet As Boolean = False, _
                           Optional new_name As String = vbNullString, _
                           Optional paste_type As PasteType = ptRange, _
                           Optional column_autofit As Boolean = False, _
                           Optional select_array As SelectArray = case_source) As Variant
    
    Dim Ws As Worksheet
    Dim Sh As Worksheet
        ' シート名の指定がない場合、
        If sheet_name = vbNullString Then

        ' ActiveSheetにそのまま貼り付ける場合と、原紙シートのようなものを
        ' コピーして使用する場合で分岐。
            Select Case copy_sheet
                Case False
                    Set Sh = ActiveSheet
                Case True
                    ActiveSheet.Copy After:=Sheets(Sheets.Count)
                    Set Sh = ActiveSheet
                    If new_name <> vbNullString Then
                        Sh.Name = new_name
                    End If
            End Select

        ' シート名の指定があって、かつシートが存在する場合、そのシートに貼り付ける｡
        ' ただし、copy_sheetフラグがTrueの場合は、そのシートをコピーしたうえで貼り付ける｡
        ' シート名の指定があって、かつシートが存在しない場合、シートを新規作成する｡
        Else
            For Each Ws In Worksheets
                If Ws.Name = sheet_name Then
                    Select Case copy_sheet
                        Case False
                            Set Sh = Ws
                        Case True
                            Ws.Copy After:=Sheets(Sheets.Count)
                            Set Sh = ActiveSheet
                            If new_name <> vbNullString Then
                                Sh.Name = new_name
                            End If
                    End Select
                    Exit For
                End If
            Next
            If Sh Is Nothing Then
                Sheets.Add After:=Sheets(Sheets.Count)
                Set Sh = ActiveSheet
                    Sh.Name = sheet_name
            End If
        End If

    Dim DestinationRange As Range
    On Error Resume Next
    Set DestinationRange = Sh.Range(destination)
    On Error GoTo 0

    If Err.Number <> 0 Then
        MsgBox "貼り付け先のアドレス指定に誤りがあるため、処理を中断します｡ "
        Exit Function
    End If
    
        TempArray = GetTempArray(select_array)

    ' 指定範囲に配列を貼り付け。
    Dim TargetRange As Range
    
        Select Case GetArrayDimension(TempArray)
            Case 1
                Set TargetRange = DestinationRange.Resize(, UBound(TempArray))
            Case 2
                Set TargetRange = DestinationRange.Resize(rMax - rMin + 1, cMax - cMin + 1)
            Case Else
                Exit Function
        End Select
        TargetRange = TempArray

    ' 貼り付けタイプがテーブルの場合、貼り付けたデータをテーブルに
    ' 変更したうえで、戻り値を同テーブルとする。
    If paste_type = ptTable Then
        Dim TableName As String
            TableName = "Table_" & Format(Now, "yyyymmdd_hhmmss")

            Sh.ListObjects.Add(, TargetRange, False, xlYes).Name = TableName
            Set PasteArray = Sh.ListObjects(TableName)
                PasteArray.TableStyle = "PersonalTableStyle01"
            With TargetRange
                .Font.Name = "メイリオ"
                .Font.Size = 10
                .RowHeight = 20
            End With
    Else
    ' 貼り付けタイプが範囲の場合、戻り値を貼り付け先シートとする。
        Set PasteArray = Sh
    End If

    If column_autofit Then
        TargetRange.EntireColumn.AutoFit
    End If

End Function

' 二つの配列を比較して、変更・追加・削除状況を調べた結果を返す。
' この関数は、二つの配列がユニークなキー情報を持っている場合に限定して使用可能。
Public Function CompareResultArray(arr As Variant, _
                          Optional key_index As Long = 1, _
                          Optional select_array As SelectArray = case_source) As Variant

        tempArray = GetTempArray(select_array)
    
        ' 調査結果を記すため、配列の最後尾に一列追加。
'        ColumnCutAndPaste cMax, cMax, xlCopy, cpInsert, , select_array
        ColumnInsertBlank cMax + 1, , select_array
        tempArray = edited_array
        
        ' まず最終列に全て、「削除」をセット。
        ' 削除で無ければ、結果を上書きする。
        For r = rMin To rMax
            edited_array(r, cMax) = "削除"
        Next
    
    ' 比較する配列のループカウンタ。
    Dim j As Long
    ' 検索キーワードが見つかった行番号。
    Dim k As Long
    ' 変更点の有無を知るためのカウンタ。
    Dim Counter As Long
    ' 表形式で変更点を返すための配列。
    Dim CounterForReport As Long
    Dim ReportArray() As Variant
    ReDim ReportArray(1 To rMax * cMax, 1 To 5)
        ReportArray(1, 1) = "キー情報"
        ReportArray(1, 2) = "項目名"
        ReportArray(1, 3) = "変更前"
        ReportArray(1, 4) = "変更後"
        ReportArray(1, 5) = "確認日"
        CounterForReport = 2
    
        For j = LBound(arr) To UBound(arr)
            Counter = 0
            
            ' キー情報が調査対象となる配列に存在しない場合、それは
            ' 今回、対象配列に追加されたことを意味する。
            ' 従って、調査したレコードをそのままコピーし、最終列に
            ' 「追加」をセットする。
            If ColumnFind(arr(j, key_index), , key_index) Is Nothing Then
                RowAdd WorksheetFunction.index(arr, j, 0), , cpInsert, case_edited
                edited_array(rMax, cMax) = "追加"
            
            ' キー情報が対象配列に存在する場合、レコードの内容を
            ' 一つずつ比較する。一致しないものがあれば、「⇒」で
            ' つないでcounterをカウントアップ。
            Else
                k = ColumnFind(arr(j, key_index), , key_index).Item(1)
                For c = cMin To cMax - 1
                    If edited_array(k, c) <> arr(j, c) Then
                        
                        ReportArray(CounterForReport, 1) = arr(j, key_index)
                        ReportArray(CounterForReport, 2) = arr(1, c)
                        ReportArray(CounterForReport, 3) = edited_array(k, c)
                        ReportArray(CounterForReport, 4) = arr(j, c)
                        ReportArray(CounterForReport, 5) = Date
                        
                        edited_array(k, c) = edited_array(k, c) & " ⇒ " & arr(j, c)
                        Counter = Counter + 1
                        CounterForReport = CounterForReport + 1
                    End If
                Next
                
            ' カウンターが０ならば、レコード内容に変更なしを意味する。
            ' 従って、最終列の文字「削除」を削除する。
                If Counter = 0 Then
                    edited_array(k, cMax) = vbNullString
            
            ' カウンターが１以上の場合、何某かの変更があったことを意味する。
            ' 従って、最終列の文字を「変更」に変更する。
                Else
                    edited_array(k, cMax) = "変更"
                End If
            End If
        Next
        
    Dim TempReportArray() As Variant
    ReDim TempReportArray(1 To CounterForReport - 1, 1 To 5)
        For i = 1 To UBound(TempReportArray)
            For j = 1 To 5
                TempReportArray(i, j) = ReportArray(i, j)
            Next
        Next
        
        CompareResultArray = edited_array
        invers_array = TempReportArray
    
End Function

' 指定列で指定キーワードを検索し、該当する
' 列番号をコレクションで返す。
Public Function ColumnFind(cf_What As Variant, _
                  Optional cf_LookAt As Excel.XlLookAt = xlWhole, _
                  Optional find_column_index As Long = 1, _
                  Optional select_array As SelectArray = case_source) As Collection
                  
    Dim LocalTempArray As Variant
        LocalTempArray = GetTempArray(select_array)
    
    ' 部分一致で検索する場合、検索キーワードの前後にアスタリスクを追加。
    ' これにより、Like演算子で前後方一致とする。
    If cf_LookAt = xlPart Then
        cf_What = "*" & cf_What & "*"
    End If
    
    Dim col As Collection
    Set col = New Collection
    
    ' 一致する場合、その行番号をコレクションに格納。
    For r = LBound(LocalTempArray) To UBound(LocalTempArray)
        If LocalTempArray(r, find_column_index) Like cf_What Then
            col.Add r
        End If
    Next
    
    ' 一つ以上一致する場合のみ、取得したコレクションを返す。
    ' 該当行が無い場合、Nothingとなる。
    If col.Count >= 1 Then
        Set ColumnFind = col
    End If
End Function

' 第一指定列の項目ごとに、第二指定列の指定条件のみを残す。
' 例えば、各都道府県の最年長者を抽出する、といった目的に用いる。
Public Function FilteringArrayAtDesignatedCriteria(item_column As Long, _
                                                   filter_column As Long, _
                                          Optional filter_type As Excel.XlConsolidationFunction = xlMax, _
                                          Optional select_array As SelectArray = case_source) As Variant
    
    TempArray = GetTempArray(select_array)
    
    Dim Dict As Object
    Set Dict = CreateObject("Scripting.Dictionary")
    
    ' 第一指定列の値。
    Dim myKey As Variant
    ' 第二指定列の値。
    Dim FilterItem As Variant
    ' 各レコードをスライスして格納するための配列。
    Dim arr As Variant
        ' 最小値または最大値にのみ対応しているため、それ以外の引数が
        ' 与えられた場合は、強制的に最大値を抽出することとする。
        If filter_type <> xlMin And filter_type <> xlMax Then filter_type = xlMax
    
        For i = rMin To rMax
            ' 第一指定列の値を取得。
            myKey = TempArray(i, item_column)
            ' 比較するための値を所得。
            FilterItem = TempArray(i, filter_column)
            ' 処理毎のレコードを一次元配列として取得。
            arr = WorksheetFunction.index(TempArray, i, 0)
            ' 取得した第一指定列の値が辞書に存在しないなら、比較対象が無いため
            ' 無条件で辞書に登録する。
            If Not Dict.Exists(myKey) Then
                Dict(myKey) = arr
            ' 辞書に登録されているが、第二指定列の値が数値でない場合、大小の比較が
            ' できないため処置しない。
            ' ※ただし、繰り返し登場するラベル行のようなものの場合、最初に登場した
            ' 　場合は辞書に存在しないため、辞書に登録される。
            ElseIf Not IsNumeric(TempArray(i, filter_column)) Then
            ' 辞書に登録されていて、且つ第二指定列の値が数値の場合、辞書に登録済みの
            ' 値と大小を比較する。最大値を指定していて且つ、辞書に登録済みの値よりも
            ' FilterItemが大きい場合、辞書の登録済み値を更新（上書き）する。
            ' ※最長値が指定された場合も同様。
            Else
                Select Case filter_type
                    Case xlMax
                        If Dict(myKey)(filter_column) < TempArray(i, filter_column) Then
                            Dict(myKey) = arr
                        End If
                    Case xlMin
                        If Dict(myKey)(filter_column) > TempArray(i, filter_column) Then
                            Dict(myKey) = arr
                        End If
                End Select
            End If
        Next
    
    ' 辞書に登録された数に合わせて配列をサイズ変更し、改めて
    ' 辞書の内容を配列にセットする。
    ' ※全て上書きするため、ReDim Preserve（サイズ変更前の値の保持）は不要。
    ReDim TempArray(rMin To Dict.Count, cMin To cMax)
        i = rMin
        For Each myKey In Dict.Keys
            For c = cMin To cMax
                TempArray(i, c) = Dict(myKey)(c)
            Next
            i = i + 1
        Next
        
        FilteringArrayAtDesignatedCriteria = TempArray
        edited_array = FilteringArrayAtDesignatedCriteria
        invers_array = Array()
End Function

' 配列内の文字列置き換え。
' 置換前と置換後の文字を列記して、ParamArrayキーワードで配列として受け取る。
' ０，２，４，６・・・番目が置換前
' １，３，５，７・・・番目が置換後
' となる。組合せは（０，１），（２，３）・・・の順。
Public Function MultipleSubstitution(select_array As SelectArray, _
                                     ParamArray str()) As Variant
    
    ' ParamArrayは省略可能な引数ではないため、select_arrayを省略
    ' 可能な引数にすることはできない。
    ' ※省略可能な引数の後に続く引数は全て、省略可能であることが必須のため。
    ' 以前に公開したverには、この引数が存在しないため、これについては
    ' 現在のverと互換性が無い。要注意のこと。
    TempArray = GetTempArray(select_array)
                                     
    ' 置換前と置換後の組合せ数を、配列の最大数÷２から求める。
    ' ※引数が奇数個の場合を想定して、RoundDown関数で切り捨て。
    ' ※その場合、最後に指定した文字はvbNullstringと置換される。
    Dim iMax As Long
        iMax = WorksheetFunction.RoundDown(UBound(str) / 2, 0)
    
    ' 置換前文字。
    Dim msWhat() As Variant
    ReDim msWhat(iMax)
    
    ' 置換後文字。
    Dim msReplacement As Variant
    ReDim msReplacement(iMax)
    
    ' 置換前後の文字を配列に格納する。
    ' ※奇数個指定の場合、最後の置換前文字に対する置換後文字が
    ' 　vbNullStringになるよう、エラーを無視させている。
        On Error Resume Next
        For i = 0 To UBound(str)
            msWhat(i) = str(2 * i)
            msReplacement(i) = str(2 * i + 1)
        Next
        On Error GoTo 0
    
    ' 配列内の全ての文字列に対し、置換処理を行う。
        For r = rMin To rMax
            For c = cMin To cMax
                For i = 0 To iMax
                    TempArray(r, c) = Replace(TempArray(r, c), _
                                              msWhat(i), _
                                              msReplacement(i))
                Next
            Next
        Next
        
        MultipleSubstitution = TempArray
        edited_array = MultipleSubstitution
        invers_array = Array()
End Function

'［用　途］
'   配列の次元数取得
'
'［引　数］
'   arr As Variant  配列
'
'［戻り値］
'   正常終了    配列の次元数
'   -1の場合    異常終了　※つまり、arrは配列ではない
Private Function GetArrayDimension(arr As Variant) As Long
    
    If IsArray(arr) = False Then
        GetArrayDimension = -1
        Exit Function
    End If
    
    ' 配列の次元数を取得。
    
    Dim i As Long
    Dim TempNumber As Long
        
        On Error Resume Next
        Do While Err.Number = 0
            i = i + 1
            TempNumber = UBound(arr, i)
        Loop
        
        GetArrayDimension = i - 1

End Function

'［用　途］
'   二次元配列について、一次元のサイズを変更する
Public Function SpecialRedim(ByVal arr As Variant, _
                             update_size As Long, _
                    Optional preserve_flag As Boolean = True) As Variant
        
        ' 最大次元であればRedimでサイズ変更可能なため、一旦行と列を入れ替える。
        arr = WorksheetFunction.Transpose(arr)
        
        ' サイズ変更。
        Select Case preserve_flag
            Case True
                ReDim Preserve arr(LBound(arr) To UBound(arr), _
                                   LBound(arr, 2) To update_size)
            Case False
                ReDim arr(LBound(arr) To UBound(arr), _
                          LBound(arr, 2) To update_size)
        End Select
        
        ' 再び行と列を入れ替え。
        SpecialRedim = WorksheetFunction.Transpose(arr)
End Function

Private Function SetPersonalTableStyle() As TableStyle
    Dim TableStyle As Excel.TableStyle
    
    ' 作成済みの場合、エラーになる。
        On Error Resume Next
    Set TableStyle = ActiveWorkbook.TableStyles.Add("PersonalTableStyle01")
        If Err.Number <> 0 Then
            Set SetPersonalTableStyle = ActiveWorkbook.TableStyles("PersonalTableStyle01")
            Exit Function
        End If
        
    ' テーブルスタイルを表示して、選択可能にする。
        TableStyle.ShowAsAvailableTableStyle = True
        
    Dim ElementTypeIndex As Variant
    Dim BordersIndex As Variant
    
    ' 以下は個人的好みを反映したものであるため、任意に変更可。
    
    ' 全体と見出し行を設定。
        For Each ElementTypeIndex In Array(xlWholeTable, xlHeaderRow)
            With TableStyle.TableStyleElements.Item(ElementTypeIndex)
            
            ' 一旦すべての罫線を削除する。
                .Borders.LineStyle = xlNone
                .Borders(xlInsideHorizontal).LineStyle = xlNone
                .Borders(xlInsideVertical).LineStyle = xlNone
                
            ' 上下の罫線を設定。
                For Each BordersIndex In Array(xlEdgeTop, xlEdgeBottom)
                    With .Borders(BordersIndex)
                        .ThemeColor = xlThemeColorLight1
                        .TintAndShade = 0.5
                        .Weight = xlThin
                    End With
                Next
            End With
        Next
        
        ' 見出し行の塗りつぶし設定。
        With TableStyle.TableStyleElements.Item(xlHeaderRow)
            With .Interior
                .ThemeColor = xlThemeColorDark1
                .TintAndShade = -0.05
            End With
        End With
        
        Set SetPersonalTableStyle = TableStyle
End Function

' 行列のループ上下限（4つ）を求める。
Private Property Get rMin() As Long
    rMin = LBound(TempArray, 1)
End Property

Private Property Get rMax() As Long
    rMax = UBound(TempArray, 1)
End Property

Private Property Get cMin() As Long
    cMin = LBound(TempArray, 2)
End Property

Private Property Get cMax() As Long
    cMax = UBound(TempArray, 2)
End Property

参考まで。