一番上の入り口へ > excel > VBA コーディングライブラリ集 > 部分一致する行を削除するマクロ(テスト付き)

部分一致する行を削除するマクロ(テスト付き)

指定列でセルの中の文字列が部分一致したら その行を削除するマクロ

testMode を trueにすれば、削除する前に対象業が確認できます。 (背景黄色)


Sub 任意部分一致行削除()

    '使い方
    'マクロ実行指定範囲:セレクション左上から その列と右隣の1列が空で無い行(maxRow行)まで
    '対象業は matchTargetによる部分一致
    '処理は  削除 or 色つけ(testMode : true)
    
    Dim r As Integer, c As Integer
    Dim tc As Integer
    
    Dim voidnum As Integer, voidmaxnum As Integer, maxRow As Integer
    
    '部分一致文字列
    matchTarget = "heet"
    
    '各種メイン設定値
    r = Selection.row
    c = Selection.column
    tc = c + 1
    
    voidmaxnum = 5
    maxRow = 30000
    testMode = True ' 色塗り or 実際に削除
    
    '最大行チェック(c 列と tc列がしばらく空でないかどうか: voidmaxnum)
    For i = r To maxRow
        If (Cells(i, tc).Value = Empty And (Cells(i, c).Value = Empty Or Cells(i, c).Value = "")) Then
            '空の場合、抜けるが
            
            '空でも一定の行数(voidmaxnum行)  念のためチェックする
            voidnum = voidnum + 1
            If (voidmaxnum < voidnum) Then
                maxRow = i - voidmaxnum - 1
                Exit For
            End If
            
        Else
            voidnum = 0
        End If
    Next
    
    Ans = MsgBox("任意部分一致行削除 します。" & vbCrLf & "pos: " & r & "," & c & "  最大列: " & maxRow _
                  & "  部分一致ターゲット: " & matchTarget & "  testモード: " & testMode, vbYesNo)
    If (Ans = vbNo) Then
        MsgBox "キャンセルしました"
        Exit Sub
    End If
    
    'リフレッシュチェック
    If maxRow - r > 50 Then
        Application.ScreenUpdating = False
    End If
    
    Index = 0
    For i = r To maxRow
        If (Cells(i, c).Value Like "*" & matchTarget & "*") Then
            Rows(i).Select
            
            If testMode = True Then
                '色つけ
                With Selection.Interior
                    .ColorIndex = 6
                    .Pattern = xlSolid
                End With
            Else
                '削除
                Selection.Delete Shift:=xlUp
                i = i - 1
            End If
    
            Index = Index + 1
        End If
        
        If (i Mod 500 = 0) Then
            Application.ScreenUpdating = True
            Application.ScreenUpdating = False
        End If
    
    Next
    
    Application.ScreenUpdating = True
    MsgBox "処理数: " & Index

End Sub

類似リンク

指定列が重複している行を削除するマクロ

空白行を削除するマクロ(テスト付き)

VBA マクロライブラリ集