二次元配列で列をフィルター（正規表現）

昨日は、二次元配列の指定列内で、特定の文字がある行を残す、または消すことに挑戦した。
infoment.hatenablog.com

ここまで来ると次は正規表現を用い、もう少しだけ複雑な抽出をしてみたくなる。挑戦してみよう。

といっても、内容は昨日と殆ど変わらない。正規表現を使用する時点で完全一致は有り得ず、昨日のような「完全一致 または 部分一致」の選択肢はない。
むしろ、如何に正しくパターンを作成できるかが肝となってくる。

そのため内容は殆ど同じであるものの、プロシージャとしては完全に別物とした。

クラスモジュール（ArrayEditClass）

' 行フィルター抽出の正規表現版
Public Function RowRegExpFilter(filt_pattern As Variant, _
                          column_index As Long, _
                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 myReg As Object
    Set myReg = CreateObject("VBScript.RegExp")
        myReg.IgnoreCase = False
        myReg.Pattern = filt_pattern
    
    ' フィルター。
    Dim iR As Long
    Dim iD As Long
        iR = StartRowIndex
        iD = StartRowIndex
        For r = StartRowIndex To rMax
            
            ' 消した結果の配列。
            If myReg.test(source_array(r, column_index)) = False 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
        
        RowRegExpFilter = TempArray_Result2
End Function

最近何度か追加したので、クラスモジュールの全文もこちらに載せておく。

クラスモジュール（SeaquenceClass）

Public Function TargetArray(SourceArray As Variant) As ArrayEditClass
    Set TargetArray = New ArrayEditClass
        TargetArray.source_array = SourceArray
End Function

ArrayEditClassは全文が長いので、折りたたんで ↓ 紹介。

◆ArrayEditClass（クリックで展開）◆

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
' フィルターで消すか残すかの選択肢
Enum RemainOrDelete
    rdRemain
    rdDelete
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 RowExchange(row_index_1 As Long, _
                            row_index_2 As Long) As Variant
    Dim r_low As Long
        r_low = WorksheetFunction.Min(row_index_1, row_index_2)
    Dim r_high As Long
        r_high = WorksheetFunction.Max(row_index_1, row_index_2)
    
        source_array = RowCutAndPaste(r_high, r_low, xlCut, cpInsert, xlDown)
        RowExchange = RowCutAndPaste(r_low + 1, r_high, xlCut, cpInsert, xlUp)
End Function

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

' 行フィルター抽出の正規表現版
Public Function RowRegExpFilter(filt_pattern As Variant, _
                          column_index As Long, _
                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 myReg As Object
    Set myReg = CreateObject("VBScript.RegExp")
        myReg.IgnoreCase = False
        myReg.Pattern = filt_pattern
    
    ' フィルター。
    Dim iR As Long
    Dim iD As Long
        iR = StartRowIndex
        iD = StartRowIndex
        For r = StartRowIndex To rMax
            
            ' 消した結果の配列。
            If myReg.test(source_array(r, column_index)) = False 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
        
        RowRegExpFilter = TempArray_Result2
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

それでは、テストしてみよう。
元データには、毎度おなじみ「なんちゃって個人情報」。レコード数は5000件だ。

この中から、北陸三県（北から順に新潟・富山・石川）のレコードのみ抽出して、別のシートに書き出してみる。

Sub test()
    Dim SQC As SeaquenceClass
    Set SQC = New SeaquenceClass
    
    Dim arr_1() As Variant
    Dim arr_2() As Variant
    
        arr_1 = Range("A1").CurrentRegion.Value
        arr_2 = SQC.TargetArray(arr_1).RowRegExpFilter("(新潟|富山|石川)", 9, xlYes, rdRemain)
        
        Sheets.Add After:=ActiveSheet
        Range("A1").Resize(UBound(arr_2), UBound(arr_2, 2)) = arr_2
End Sub

結果は ↓ こちら。

編集前後の画面を確認できるよう、各々５秒ずつキープしているため分かり難いが、ほぼ一瞬で抽出を終えている。
結構いい感じかも。明日に続きます。

参考まで。