二次元配列で任意の一行をカット＆挿入（再挑戦）

昨日は、二次元配列で任意の一行に対し何某かを挿入する際、xlUPとxlDownを選択できるようにした。
infoment.hatenablog.com

この結果を踏まえ、先日の ↓ に再挑戦する。
infoment.hatenablog.com

昨日も紹介したように、xlUPで上に押し上げるということは、指定行を一つ下に下げてxlDownするのと同じこと。この部分はたびたび登場するので、切り出して関数化した。

' シフトの方向による、挿入対象列との差分を求める。
' 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

数学的に多少なりともテクニカルな部分であるため解説すると、以下の通り。

row_shift = xlDownの場合。
(xlDown - row_shift) / (xlDown - xlUP)
= (xlDown - xlDown) / (xlDown - xlUP)
= 0 / (xlDown - xlUP)
= 0

従って、指定行からの変更は無い。

row_shift = xlUpの場合。
(xlDown - row_shift) / (xlDown - xlUP)
= (xlDown - xlUP) / (xlDown - xlUP)
= 1

従って、指定行の１行下を、指定行に改める。

カット＆ペーストの部分にも手を加えた。例えば「貼り付け」なのに、シフト方向を指定しても仕方がないし、xlUpを指定するとエラーになってしまう（一番下に加えようとするとはみ出すため）。その辺りを加味した結果が、こちら。

' カット＆ペースト
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) As Variant
                       
    Dim arr As Variant
        arr = source_row_array(source_row_index)
                       
    ' 貼り付け または 挿入先を準備。
    ' 貼り付けの場合は処置不要。
        If overwrite_or_insert = cpInsert Then
            source_array = RowInsert(destination_row_index, row_shift)
    ' 上書きでxlUpを指定すると、行方向で要素数がオーバーするため、強制的にxlDownとする。
        ElseIf overwrite_or_insert = cpOverWrite Then
            row_shift = xlDown
        End If
    
    ' 貼り付け または 挿入。
        For c = cMin To cMax
            source_array(destination_row_index + dr(row_shift), c) = arr(1, c)
        Next
    
    ' カット または コピー
    ' コピーの場合は処置不要。
        If cut_or_copy = xlCut Then
        ' 挿入行がカット行以前にある場合、カット行を＋１。
            If overwrite_or_insert = cpInsert Then
                If source_row_index >= destination_row_index Then
                    source_row_index = source_row_index + 1
                End If
            End If
            RowCutAndPaste = RowDelete(source_row_index)
        Else
            RowCutAndPaste = source_array
        End If

End Function

以上を踏まえた、クラスモジュールのコード全文が ↓ こちら。

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

Option Explicit

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

' 編集前の配列。
Public source_array As Variant
' ループ用変数：行
Dim r As Long
' ループ用変数：列
Dim c As Long
' ループ用変数：カウントアップ用（行と列併用）
Dim i As Long
' 作業結果の仮置用
Dim TempArray As Variant
' 編集内容の選択肢
Enum ProcessIndex
    ' 削除（上詰め）
    piDelete = -1
    ' 空白
    piBlank
    ' 空白挿入
    piInsert
End Enum
' カット＆ペーストの貼り付け選択肢
Enum CutAndPasteResult
    cpInsert
    cpOverWrite
End Enum


' row_index 行目を削除。
Public Function RowDelete(row_index As Long) As Variant
    RowDelete = RowEdit(row_index, piDelete)
End Function

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

' row_index 行目を空白化。
Public Function RowBlank(row_index As Long) As Variant
    ' 指定行が最終行の場合、最終行の中身を空白化。
    If row_index = rMax Then
        For c = cMin To cMax
            source_array(row_index, c) = vbNullString
        Next
        RowBlank = source_array
        Exit Function
    End If

    ' 一旦、指定行を削除する。
    source_array = RowDelete(row_index)
    ' 指定行に空白を挿入して、指定行の空白化に代える。
    ' ただし、最終行を削除した場合は完成形となっているため、
    ' 削除結果をそのまま返すものとする。
    If row_index > UBound(source_array) Then
        RowBlank = source_array
    Else
        RowBlank = RowInsert(row_index)
    End If
End Function

' 行編集。
Private Function RowEdit(row_index As Long, _
                         p_index As ProcessIndex, _
                Optional row_shift As Excel.XlDirection = xlDown) As Variant
                
    ' 変更後の最大行数算出。
    Dim TempMax As Long
        TempMax = rMax + p_index + dr(row_shift)
    
    ' 編集後の配列（仮置用）
    ReDim TempArray(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
                TempArray(r, c) = source_array(i, c)
            Next
            On Error GoTo 0
            i = i + 1
        Next
        RowEdit = TempArray
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) As Variant
                       
    Dim arr As Variant
        arr = source_row_array(source_row_index)
                       
    ' 貼り付け または 挿入先を準備。
    ' 貼り付けの場合は処置不要。
        If overwrite_or_insert = cpInsert Then
            source_array = RowInsert(destination_row_index, row_shift)
    ' 上書きでxlUpを指定すると、行方向で要素数がオーバーするため、強制的にxlDownとする。
        ElseIf overwrite_or_insert = cpOverWrite Then
            row_shift = xlDown
        End If
    
    ' 貼り付け または 挿入。
        For c = cMin To cMax
            source_array(destination_row_index + dr(row_shift), c) = arr(1, c)
        Next
    
    ' カット または コピー
    ' コピーの場合は処置不要。
        If cut_or_copy = xlCut Then
        ' 挿入行がカット行以前にある場合、カット行を＋１。
            If overwrite_or_insert = cpInsert Then
                If source_row_index >= destination_row_index Then
                    source_row_index = source_row_index + 1
                End If
            End If
            RowCutAndPaste = RowDelete(source_row_index)
        Else
            RowCutAndPaste = source_array
        End If

End Function

' カット＆ペースト用配列。
Public Function source_row_array(source_row_index) As Variant
    ReDim TempArray(1 To 1, cMin To cMax)
        For c = cMin To cMax
            TempArray(1, c) = source_array(source_row_index, c)
        Next
    source_row_array = TempArray
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

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

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

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

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

そして、テストした結果がこちら。

Sub test()
    Dim SQC As SeaquenceClass
    Set SQC = New SeaquenceClass
    
    Dim arr_1() As Variant
    Dim arr_2() As Variant
    Dim arr_3() As Variant
    Dim arr_4() As Variant
    Dim arr_5() As Variant
    
    Dim i As Long
        For i = 1 To 8
            arr_1 = Range("A1").CurrentRegion.Value
            arr_2 = SQC.TargetArray(arr_1).RowCutAndPaste(4, i, xlCut, cpInsert, xlUp)
            arr_3 = SQC.TargetArray(arr_1).RowCutAndPaste(4, i, xlCut, cpOverWrite, xlUp)
            arr_4 = SQC.TargetArray(arr_1).RowCutAndPaste(4, i, xlCopy, cpInsert, xlUp)
            arr_5 = SQC.TargetArray(arr_1).RowCutAndPaste(4, i, xlCopy, cpOverWrite, xlUp)
            
            Range("A12").Resize(UBound(arr_2), UBound(arr_2, 2)) = arr_2
            Range("F12").Resize(UBound(arr_3), UBound(arr_3, 2)) = arr_3
            Range("A22").Resize(UBound(arr_4), UBound(arr_4, 2)) = arr_4
            Range("F22").Resize(UBound(arr_5), UBound(arr_5, 2)) = arr_5
            MsgBox i
        Next
End Sub

一応今回も、意図した動きを実現した。

本シリーズの最終回まで、あと２～３回！

以上、参考まで。