キャリア別でシートを作成

いつもの、なんちゃって個人情報。

こちらで、キャリア別にシートを作成したくなったとする。
そこで、先日から改修している↓に手を加えてみた。
infoment.hatenablog.com

今回も手を加えたのは、RowFilter関数。元々は指定ワードを含むレコードを残すか、または消すかの選択を行っていた。

そこで今回は、残すかまたは消した結果、或いはその逆で、元の配列を更新する引数を追加してみた（賛否両論ありそう）。

' 編集前の配列。
Public source_array As Variant

' ----------------↓今回追加↓----------------
' source_arrayの更新
Enum UpdateSource
    usNone      ' 更新しない
    usResult    ' 編集した結果でsource_arrayを更新
    usInvers    ' 編集した結果の残りで更新
End Enum

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

    ' 仮置用：残す場合。
    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
        
    ' ----------------↓今回追加↓----------------
        
    ' Source_arrayの更新確認。
        Select Case rf_source_update
            ' 更新しない。
            Case usNone
            
            ' 得られた結果で更新する。
            Case usResult
                source_array = RowFilter
                
            ' 得られた結果の逆側で更新する。
            ' 例えば戻り値が「消す」なら、source_arrayは「残す」で更新。
            Case usInvers
                Select Case rf_result
                    Case RemainOrDelete.rdDelete
                        TempArray_Result1 = TempArray_Remain
                        i = iR - 1
                    Case RemainOrDelete.rdRemain
                        TempArray_Result1 = TempArray_Delete
                        i = iD - 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
                    
                    source_array = TempArray_Result2
        End Select
        
End Function

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

Sub test()
    ' 名簿格納用配列。
    Dim arr As Variant
    
    ' テーブル（なんちゃって個人情報）。
    Dim Tb As Excel.ListObject
    Set Tb = ActiveSheet.ListObjects(1)

        With New ArrayEdit
            ' テーブル全体を元となる配列に格納する。
            .source_array = Tb.Range
            
            ' キャリア別でシートを作成。
            Dim キャリア As Variant
            Dim Sh As Worksheet
                For Each キャリア In Array("ドコモ", "ソフトバンク", "ツーカー", "au")
                    arr = .RowFilter(filt:=キャリア, _
                                     column_index:=Tb.ListColumns("キャリア").Index, _
                                     rf_result:=rdRemain, _
                                     rf_source_update:=usInvers)
                                     
                    Set Sh = Sheets.Add(After:=Sheets(Sheets.Count))
                        Sh.Name = キャリア
                        Range("A1").Resize(UBound(arr), UBound(arr, 2)) = arr
                Next
        End With
End Sub

結果、キャリアごとに４つのシートが作成された。

これは、意外と使えるかも。

参考まで。