配列の一部を抽出して、新たな配列として返すユーザー定義関数

以前、このようなものを作成して紹介した。
infoment.hatenablog.com
ところが最近、これでは間に合わない事例が出てきたので、思い切ってもう一つ作ることにした。
f:id:Infoment:20190214222026p:plain
といっても、特別なことをするわけではない。二次元配列に限定して、抜き出したい行と列の最小値と最大値を指定するだけ。後は愚直に、転記作業をこなすだけ。こんな感じだ。
※今回は解説を兼ねて、いつもよりコード内のコメントを充実させている。

まず、二次元配列であることを確認する。

' 二次元配列確認用。
Function CheckDimmension(seq As Variant) As Boolean
    On Error Resume Next
    
    '二次元要素数の上限を､イミディエイトウィンドウに表示｡
    'エラーが出る ⇒ 二次元要素が無い ⇒ 一次元配列。
    Debug.Print UBound(seq, 2)
    If Err.Number <> 0 Then Exit Function
    
    ' 三次元要素の上限を、イミディエイトウィンドウに表示。
    ' エラーが出ない ⇒ 三次元以上の配列。
    Debug.Print UBound(seq, 3)
    If Err.Number = 0 Then Exit Function
    On Error GoTo 0
    
    ' それ以外の場合は、二次元配列。
    CheckDimmension = True
End Function

次いで、元の配列から、指定された行と列の下限から上限まで抜き出してみる。

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

        ExtractArray = TempSeq
End Function

なお、１行または１列の二次元配列を一次元配列に変換する方法については、こちらを参照されたし（いつも有難うございます）。
thom.hateblo.jp

それでは、動作を確認してみる。確認には、いつもの「なんちゃって個人情報」を使用（こちらも、ありがとうございます）。
f:id:Infoment:20190214223414p:plain

まず、一旦表の全てを配列に格納したのち、２行目以降を抽出してSheet2に貼り付けてみる。
※貼り付け部分のコードは、今回のテーマではないので割愛する。

Sub test()
    Dim seq As Variant
        seq = Sheet1.Range("A1").CurrentRegion
        seq = ExtractArray(seq, 2)
        
    Dim SQC As SeaquenceClass
    Set SQC = New SeaquenceClass
    
        Cells.Clear
        SQC.PasteArray Range("A1"), seq
        Cells.EntireColumn.AutoFit
End Sub