二次元配列で指定列の値のうち、指定値以上の行だけ残したい

Excel VBA クラスモジュール

二次元配列で指定列の値のうち、指定値以上の行だけ残したいケースが登場した。

例えば、↓ このような値において、
f:id:Infoment:20191026235751p:plain

↓ このようにしたい。
f:id:Infoment:20191026235845p:plain

そこで、先日来取り組んできたクラス「ArrayEdit」の機能拡張に挑戦した。
f:id:Infoment:20191027000101p:plain

折角なので、以下の選択肢全てに対応させてみた。
【指定値との関係】

  1. 指定値以上の場合
  2. 指定値を超える場合
  3. 指定値以下の場合
  4. 指定値未満の場合

【処理の内容】

  1. 残す
  2. 消す

まず、引数名で「以上」「超える」を英語でどう表現するかに迷った。色々調べると、両方とも「over」と書かれていたりする。変数名から直感的な理解に繋がりにくく、場合によっては勘違いする場合もありそうだ。

そこで今回は、腹を括って以下に決め打ちした。

' 大小比較用
Enum HighOrLow
    hlMore  ' 以上
    hlLess  ' 以下
    hlAbobe ' 超
    hlBelow ' 未満
End Enum

また、以上・以下などの４パターン × 残す・消すの２パターンで、計８パターンの場合分けが必要だ。複雑化は必至のため、この機能は別の関数とした。
引数である二つの値を比較し、残すか否かを戻り値としている。

Private Function CompareResultValue(ByVal val1 As Variant, _
                                    ByVal val2 As Variant, _
                                    rf_type As HighOrLow, _
                                    rf_result As RemainOrDelete) As Boolean

    ' 初期値。
    CompareResultValue = False

    ' 数値か否かを確認。
    If IsNumeric(val1) = False Or IsNumeric(val2) = False Then
        Exit Function
    End If
    
    ' 大小比較。
    Select Case rf_result
        ' 残す場合。
        Case RemainOrDelete.rdRemain
            Select Case rf_type
                ' 以上の場合。
                Case HighOrLow.hlMore
                    If val1 >= val2 Then CompareResultValue = True
                ' 超える場合。
                Case HighOrLow.hlAbobe
                    If val1 > val2 Then CompareResultValue = True
                ' 以下の場合。
                Case HighOrLow.hlLess
                    If val1 <= val2 Then CompareResultValue = True
                ' 未満の場合。
                Case HighOrLow.hlBelow
                    If val1 < val2 Then CompareResultValue = True
            End Select
        
        
        ' 消す場合。※残す場合と逆の条件になる。
        Case RemainOrDelete.rdDelete
            Select Case rf_type
                ' 以上の場合。
                Case HighOrLow.hlMore
                    If val1 < val2 Then CompareResultValue = True
                ' 超える場合。
                Case HighOrLow.hlAbobe
                    If val1 <= val2 Then CompareResultValue = True
                ' 以下の場合。
                Case HighOrLow.hlLess
                    If val1 > val2 Then CompareResultValue = True
                ' 未満の場合。
                Case HighOrLow.hlBelow
                    If val1 >= val2 Then CompareResultValue = True
            End Select
    End Select
            
End Function

例えば、以下は同じ意味になる。

  • ３以上を残す
  • ３未満を消す

最初は、上手くやればコードの長さが半分になると考えた。しかしコードの可読性を著しく損ないそうだったため、途中で断念した。

残すか否かの部分を取り出したため、本体は割とすっきりした。

' 行フィルター抽出の数量比較版
Public Function RowNumericFilter(filt As Variant, _
                                 column_index As Long, _
                        Optional rf_type As HighOrLow = HighOrLow.hlMore, _
                        Optional rf_header As Excel.XlYesNoGuess = xlYes, _
                        Optional rf_result As RemainOrDelete = RemainOrDelete.rdDelete)


    ' 仮置用
    ReDim TempArray(rMin To rMax, cMin To cMax)
    
    ' 一行目をヘッダーと見なす場合(xlYes）、強制的に配列の一行目に組み込む。
    Dim StartRowIndex As Long
        If rf_header = xlYes Then
            For c = cMin To cMax
                TempArray(rMin, c) = source_array(rMin, c)
            Next
            StartRowIndex = rMin + 1
        Else
            StartRowIndex = rMin
        End If
    
    ' フィルター。
        i = StartRowIndex
        For r = StartRowIndex To rMax
            If CompareResultValue(source_array(r, column_index), filt, rf_type, rf_result) Then
                For c = cMin To cMax
                    TempArray(i, c) = source_array(r, c)
                Next
                i = i + 1
            End If
        Next
    
    ' 末尾にあまった空白を消すために、ピッタリサイズの配列へ転記。
    Dim TempArray_Result2() As Variant
    ReDim TempArray_Result2(rMin To i - 1, cMin To cMax)
        For r = rMin To i - 1
            For c = cMin To cMax
                TempArray_Result2(r, c) = TempArray(r, c)
            Next
        Next
        
        RowNumericFilter = TempArray_Result2
End Function

それでは、テスト。今回は全８パターンで確認。

Sub test()

    Dim SourceArray As Variant
        SourceArray = Range("A1:C12")
    Dim arr As Variant

    With New Seaquence
        arr = .TargetArray(SourceArray). _
            RowNumericFilter(filt:=3, _
                             column_index:=2, _
                             rf_type:=hlMore, _
                             rf_header:=xlYes, _
                             rf_result:=rdRemain)
                             
        Range("A8") = "２列目 ３以上を残す"
        .TargetArray(arr).PasteArray "A9"

        arr = .TargetArray(SourceArray). _
            RowNumericFilter(filt:=3, _
                             column_index:=2, _
                             rf_type:=hlMore, _
                             rf_header:=xlYes, _
                             rf_result:=rdDelete)


        Range("E8") = "２列目　３以上を消す"
        .TargetArray(arr).PasteArray "E9"
        
        arr = .TargetArray(SourceArray). _
            RowNumericFilter(filt:=3, _
                             column_index:=2, _
                             rf_type:=hlAbobe, _
                             rf_header:=xlYes, _
                             rf_result:=rdRemain)
                             
        Range("A14") = "２列目 ３より上を残す"
        .TargetArray(arr).PasteArray "A15"

        arr = .TargetArray(SourceArray). _
            RowNumericFilter(filt:=3, _
                             column_index:=2, _
                             rf_type:=hlAbobe, _
                             rf_header:=xlYes, _
                             rf_result:=rdDelete)
                             
        Range("E14") = "２列目 ３より上を消す"
        .TargetArray(arr).PasteArray "E15"
        
        arr = .TargetArray(SourceArray). _
            RowNumericFilter(filt:=3, _
                             column_index:=2, _
                             rf_type:=hlLess, _
                             rf_header:=xlYes, _
                             rf_result:=rdRemain)
                             
        Range("A20") = "２列目 ３以下を残す"
        .TargetArray(arr).PasteArray "A21"

        arr = .TargetArray(SourceArray). _
            RowNumericFilter(filt:=3, _
                             column_index:=2, _
                             rf_type:=hlLess, _
                             rf_header:=xlYes, _
                             rf_result:=rdDelete)
                             
        Range("E20") = "２列目 ３以下を消す"
        .TargetArray(arr).PasteArray "E21"
        
        arr = .TargetArray(SourceArray). _
            RowNumericFilter(filt:=3, _
                             column_index:=2, _
                             rf_type:=hlBelow, _
                             rf_header:=xlYes, _
                             rf_result:=rdRemain)
                             
        Range("A26") = "２列目 ３未満を残す"
        .TargetArray(arr).PasteArray "A27"

        arr = .TargetArray(SourceArray). _
            RowNumericFilter(filt:=3, _
                             column_index:=2, _
                             rf_type:=hlBelow, _
                             rf_header:=xlYes, _
                             rf_result:=rdDelete)
                             
        Range("E26") = "２列目 ３未満を消す"
        .TargetArray(arr).PasteArray "E27"
    
    End With
End Sub

↓ 結果、このようになった。
f:id:Infoment:20191027001558p:plain

どうやら、使えそうだ。
なお、上記は全て、↓ こちらに反映済みです。
infoment.hatenablog.com


参考まで。