二次元配列の一部を抽出：指定列番号順にスライス

最近、これの存在を知った。
docs.microsoft.com

何ということでしょう。これがあれば、簡単に配列をスライスできる。
今までの苦労は何だったのか。

本日も、毎度おなじみ「なんちゃって個人情報」のお世話になる。

例えば、一旦表全体を配列に格納したのち、

• 行番号　0
• 列番号　2

で抽出してみる。

Sub test()
    Dim arr() As Variant
        arr = ActiveSheet.UsedRange.Value
        arr = WorksheetFunction(arr, 0, 2)
End Sub

すると、配列には２列目の値が抽出され格納される。

では、これだとどうなるか。

• 行番号　0
• 列番号　2，4

Sub test()
    Dim arr() As Variant
        arr = ActiveSheet.UsedRange.Value
        arr = WorksheetFunction.Index(arr, 0, Array(2, 4))
End Sub

すると、１行目の２列目と４列目が、一次元配列として抽出された。

以上を踏まえ、このような関数を作成してみた。
※今までExtractArrayの1と2を作成、紹介してきた都合上、今回は3とした。

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

早速テストしてみよう。今回は、以下の条件を纏めてテストする。

1. 列の順序を入れ替えるとどうなるか。
2. 同じ列を複数回指定するとどうなるか。
3. ０列目を指定するとどうなるか。

Sub test()
    Dim arr() As Variant
        arr = ActiveSheet.UsedRange.Value
        
        ' 作成済み配列について、２，４，０，３，３列目を抽出。
        ' 以下について確認している。
        ' ① ４，３のような、列の入れ替えはどうなるか。
        ' ② ３，３のように、同じ列を指定するとどうなるか。
        ' ③ 存在しない０列目の抽出で、どうなるか。
        arr = ExtractArray3(arr, 2, 4, 0, 3, 3)
        
        ' 結果を別シートに貼り付け。
        Sheets.Add After:=Sheets(Sheets.Count)
        Range("A1").Resize(UBound(arr), UBound(arr, 2)) = arr
End Sub

結果、まず無事に抽出 ⇒ 貼り付けに成功した。

① 列の入れ替えについて、問題なし。指定順序通りに抽出できた。

② 同じ列の複数回指定について、問題なし。「ふりがな」を２回抽出。

③ ０列目の指定については、空白列が得られた。

実際、何が抽出されたかを見てみると、ジャグ配列（多段階配列）になっていた。

値貼り付けの時は問題ないが、思わぬ誤動作に繋がる恐れもあるため、抽出の時点で潰しておこう。

ということで、今回の最終形がこちら。

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)
                Select Case column_number(c - 1)
                    Case 0
                        arr(r, c) = vbNullString
                    Case Else
                        arr(r, c) = WorksheetFunction.Index(source_array, r, column_number(c - 1))
                End Select
            Next
        Next
        
    ' 抽出後の配列が１列のみの場合、一次元配列に変換する。
        If UBound(arr, 2) = 1 Then
            arr = WorksheetFunction.Transpose(arr)
        End If
        
        ExtractArray3 = arr
End Function

それなりに使えそうかな。

参考まで。