二次元配列で列をフィルター

一昨日は、二次元配列内の任意の二行を入れ替えることに挑戦した。
infoment.hatenablog.com

本日は、指定列内に特定の文字がある行を残す、または消すことに挑戦する。

今回は、以下の４条件を個別に満足するフィルターを作ってみよう。

1. 部分一致 または 完全一致
2. 消す または 残す

部分一致 または 完全一致については今回、Like演算子を使用することにした。
例えば、

If A Like "徳川*" Then

とした場合、「徳川」の後ろにある「*」は何が入っても構わないため、

• 徳川家康
• 徳川家光
• 徳川埋蔵金

など、徳川「何某」全てが該当してしまう。一方、Like演算子を使っていても、

If A Like "徳川" Then

のように「*」を付さない場合、これは「徳川」以外を別物と判断する。

以上を踏まえて作成したのが、こちら。とにかく、愚直に選り分けている。

クラスモジュール（ArrayEditClass）

' 行のフィルター抽出
' 初期設定：① 完全一致，②ヘッダーを含めない，③指定文字を消す
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)

    ' 仮置用：残す場合。
    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) = source_array(rMin, c)
                TempArray_Delete(rMin, c) = source_array(rMin, c)
            Next
            StartRowIndex = rMin + 1
        Else
            StartRowIndex = rMin
        End If
        
    ' 部分一致と完全一致の確認。
        If rf_LookAt = xlPart Then
            filt = "*" & filt & "*"
        End If
    
    ' フィルター。
    Dim iR As Long
    Dim iD As Long
        iR = StartRowIndex
        iD = StartRowIndex
        For r = StartRowIndex To rMax
            
            ' 消した結果の配列。
            If Not source_array(r, column_index) Like filt Then
                For c = cMin To cMax
                    TempArray_Delete(iD, c) = source_array(r, c)
                Next
                iD = iD + 1
            
            ' 残した結果の配列。
            Else
                For c = cMin To cMax
                    TempArray_Remain(iR, c) = source_array(r, c)
                Next
                iR = iR + 1
            End If
        Next
    
    ' 消すか残すか、指定された側をセット。
    Dim TempArray_Result1 As Variant
    Dim TempArray_Result2 As Variant
        Select Case rf_result
            Case RemainOrDelete.rdDelete
                TempArray_Result1 = TempArray_Delete
                i = iD - 1
            Case RemainOrDelete.rdRemain
                TempArray_Result1 = TempArray_Remain
                i = iR - 1
        End Select
    
    ' 末尾にあまった空白を消すために、ピッタリサイズの配列へ転記。
    ReDim TempArray_Result2(rMin To i, cMin To cMax)
        For r = rMin To i
            For c = cMin To cMax
                TempArray_Result2(r, c) = TempArray_Result1(r, c)
            Next
        Next
        
        RowFilter = TempArray_Result2
End Function

それでは、テストしてみよう。

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

        arr_1 = Range("A1").CurrentRegion.Value
        
        '２列目に「田」が含まれる場合を残す。
        arr_2 = SQC.TargetArray(arr_1).RowFilter("田", 2, xlPart, xlYes, rdRemain)
        '２列目に「田」が含まれる場合を除く。
        arr_3 = SQC.TargetArray(arr_1).RowFilter("田", 2, xlPart, xlYes, rdDelete)
        
        Range("A12").Resize(UBound(arr_2), UBound(arr_2, 2)) = arr_2
        Range("F12").Resize(UBound(arr_3), UBound(arr_3, 2)) = arr_3
End Sub

結果、意図したとおりに選り分けることが出来た。

完成まで、あとわずか。
明日に続きます。

参考まで。