配列のフィルターで複数の文字列指定

９ヶ月ほど前に、配列を編集する自作のクラスモジュールを纏めてみた。
infoment.hatenablog.com

その後、業務などで頻繁に使用しているうちに、幾つか修正点が出てきた。
今回は、その中の一つをご紹介。

クラスモジュールで、行のフィルター抽出を行うユーザー定義関数を作成した。

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

これにより二次元配列の指定列について、指定した文字を含む行を消すか、または残した結果を新たな配列として受け取ることが出来る。

ところが使用する内に、複数のキーワードで同時に評価したい場面が多々登場するようになった。

そこで引数filtが配列でも機能するよう作り替えてみた。

' 行のフィルター抽出
' 初期設定：① 完全一致，②ヘッダーを含めない，③指定文字を消す
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
    
    Dim arr As Variant
        If IsArray(filt) Then
            arr = filt
        Else
            arr = Array(filt)
        End If
    
    ' フィルター。
    Dim iR As Long
    Dim iD As Long
        iR = StartRowIndex
        iD = StartRowIndex
    
    Dim LoopIndex As Variant
    Dim LoopFlag As Boolean
        
        For r = StartRowIndex To rMax
            
            LoopFlag = False
            
            For Each LoopIndex In arr

                ' 部分一致と完全一致の確認。
                If rf_LookAt = xlPart Then
                    LoopIndex = "*" & LoopIndex & "*"
                End If
            
                ' 残した結果の配列。
                If source_array(r, column_index) Like LoopIndex Then
                    For C = cMin To cMax
                        TempArray_Remain(iR, C) = source_array(r, C)
                    Next
                    iR = iR + 1
                    LoopFlag = True
                    Exit For
                End If
            Next
                    
            
            ' 消す結果の配列。
            If LoopFlag = False Then
                For C = cMin To cMax
                    TempArray_Delete(iD, C) = source_array(r, C)
                Next
                iD = iD + 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

引数filtが文字列・配列のどちらでも対応できるよう、文字列の場合も強制的に、要素が一つの配列とした。

    Dim arr As Variant
        If IsArray(filt) Then
            arr = filt
        Else
            arr = Array(filt)
        End If

ちなみにこの部分には、この日の内容が活かされている。
infoment.hatenablog.com

複数のキーワードのうちどれかに一致したら、ループから抜けなければならない。しかし、抜けすぎてはいけない。その確認の結果が、この内容に繋がっている。
infoment.hatenablog.com

部分一致の場合、キーワードの前後にワイルドカードを付して、Like演算子で評価している。しかしもし、引数に与えた時点でワイルドカードが含まれていたら複数のそれが連続で登場することになるが、問題ないか。その確認の結果が、この日の内容に繋がった。
infoment.hatenablog.com

それでは、いつもの「なんちゃって個人情報」で試してみよう。

例えば都道府県について、「山*県」と「福*県」のみのレコードに絞り込みたい。先ほどのクラスを用いると、こうなる。

Sub FilterTest()
    Dim arr As Variant
    
    With New VBAProject.ArrayEdit
        ' 元の値を配列にセット。
        .source_array = ActiveSheet.UsedRange
        
        ' 都道府県の列（９列目）から、「山*県」と「福*県」を抽出。
        arr = .RowFilter(filt:=Array("山*県", "福*県"), _
                         column_index:=9, _
                         rf_LookAt:=xlWhole, _
                         rf_header:=xlYes, _
                         rf_result:=rdRemain)
                         
        ' 抽出後の配列を、新たなシート「確認」を作成して貼り付けてテーブル化。
        .source_array = arr
        Dim Tb As ListObject
        Set Tb = .PasteArray("A1", "確認", , , ptTable, True)
    End With
End Sub

結果がこちら。

少なくとも個人的には、用途の幅が広がりそうです。

参考まで。