特定の行を削除 または 残す

ある表内の特定の列について、同列が空欄以外の場合、その行を削除したいという処理がありました。

シート上で行を削除すると、気づかないうちに、余計なものまで消す恐れがあります。
そこで、マクロ内で全て加工することにしました。まず、配列の次元数を取得する関数を準備します。これは、ネット上で知恵をお借りしました。

Function GetArrayDimension(seq As Variant) As Integer
    Dim i       As Long
    Dim temp    As Variant
    ' 配列か否かの判定。
        If IsArray(seq) = False Then
            GetArrayDimension = -1
            Exit Function
        End If
    ' 配列の次元数を取得。
        On Error Resume Next
        Do While Err.Number = 0
            i = i + 1
            temp = UBound(seq, i)
        Loop
        GetArrayDimension = i - 1
End Function

次いで、不要な行を配列内で削除する関数を作成しました。今回は削除するだけでなく、逆に残すこともできるようにしました。

Function RowIncDec(ByVal seq As Variant, _
                    TargetColumnNumber As Long, _
                    TargetString As String, _
                    ProcessJudgment As Boolean) As Variant

    Dim i       As Long
    Dim j       As Long
    Dim col     As Collection
    Dim col1    As Collection
    Dim col2    As Collection
    Dim buf     As Variant

    ' 配列が二次以外の場合、処理を終了する。
        If GetArrayDimension(seq) <> 2 Then Exit Function

    ' 抽出用コレクションの初期化。
    ' col1・・・残す用
    ' col2・・・除外用
        Set col = New Collection
        Set col1 = New Collection
        Set col2 = New Collection

    ' 指定列の値が指定文字の場合、その行番号をcol1に追加する。
    ' 値が指定した文字以外の場合、その行番号をcol2に追加する。
        For i = 1 To UBound(seq, 1)
            If seq(i, TargetColumnNumber) = TargetString Then
                col1.Add i
            Else
                col2.Add i
            End If
        Next

    ' 残すか除外するかで、使用するコレクションを選択する。
        Select Case ProcessJudgment
            Case True
                Set col = col1
            Case False
                Set col = col2
        End Select

    ' コレクションに格納した行番号のレコードを、配列に格納する。
        ReDim buf(1 To col.Count, 1 To UBound(seq, 2))
        For i = 1 To UBound(buf, 1)
            For j = 1 To UBound(buf, 2)
                buf(i, j) = seq(col.Item(i), j)
            Next j
        Next i

        RowIncDec = buf

End Function

使い方のサンプルです。

Sub sample()

    Dim seq As Variant
        seq = Range("D7:F16")
        seq = RowIncDec(seq, 1, "★", True)
        
        Range("J7").Resize(UBound(seq, 1), UBound(seq, 2)) = seq

End Sub

このサンプルでは、「★」だけ残してみました。

参考まで。