選択範囲の指定列を抜き出す際に、併せて空白列を挿入する関数

昨日は選択範囲の指定列を抜き出して、別の所に貼り付ける関数を作成しました。
infoment.hatenablog.com

そのあとに考えてみたのですが、過去の事案を思い返してみれば、抜き出した列と列の間に空白列を差し込みたい場合が多々ありました。
そこで、列の指定が「0」の場合は、空白列を追加する仕様に変更してみました。

変更するのは、クラスモジュールの下記関数のみです（ほとんど最後のところ）。
［クラスモジュール］

'［用　途］
'   指定範囲から、指定列番号のみ抽出した配列を作成
'   ※指定範囲は、配列を指定可能
'［引　数］
'   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 DataSeq As Variant
        DataSeq = target_data

    ' 抽出列が抽出対象の範囲を超えている場合、処理を中断。
        If UBound(DataSeq, 2) < extract_column_array(UBound(extract_column_array)) Then
            ExtractArray = -3: Exit Function
        End If

    ' 抽出後の配列定義。
    Dim rMax As Long
        rMax = SeqRowsAndColumnsCount(DataSeq, 1)
    Dim cMax As Long
        cMax = SeqRowsAndColumnsCount(extract_column_array, 1)

    Dim TempSeq As Variant
    ReDim TempSeq(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
                    TempSeq(r, c) = DataSeq(r, extract_column_array(i))
                End If
            ' －－－↑今回変更した範囲↑－－－
            Next
            i = i + 1
        Next

        ExtractArray = TempSeq

End Function

それでは、下記サンプルで試してみましょう。

今回は、以下についてのお試しです。

1. 空白列を挿入する。
2. 列の順序を入れ替える。
3. 同じ列を複数回登場させる。

［標準モジュール］

Sub Sample()
    Dim SQC As SequenceClass
    Set SQC = New SequenceClass
    Dim seq As Variant
        seq = SQC.ExtractArray(Range("A1:E7"), Array(2, 5, 0, 3, 5))
        Call SQC.PasteArray(Range("G1"), seq)
End Sub

結果は意図したように、以下のとおりとなりました。

これはこれで、何かと使い出がありそうです。

参考まで。