CODEWITHSUNDEEP
vbaexcel
Maki
Maki

Reputation: 637

How to write a macro to remove row without specific text

I am trying to create a filter to remove rows that do not contain either one of the specified text. There are 3 situations and I am having some difficult in writing the last one (Point 3). (Excel version: 2010)

1. IF cell value = text THEN next row [complete]
2. IF cell value <> text THEN next text [complete]
3. IF cell value <> any of the text THEN delete row [not sure how to write this]

Sub Filter()

Dim i As Integer
Dim word(1 To 20) As String
Dim iRow As Integer, iCol As Integer

word(1) = "AA"
word(2) = "BB"
word(3) = "CC"
word(4) = "DD"
word(5) = "EE"
word(6) = "FF"
word(7) = "GG"
word(8) = "HH"
word(9) = "XXX"

iCol = ActiveCell.Column

For iRow = ActiveCell.End(xlDown).Row To 1 Step -1

    For i = 1 To UBound(word)
        If Cells(iRow, iCol).Value = word(i) Then
        GoTo NextRow
        Else
        GoTo Nextword
        End If
Nextword:
    Next i

NextRow:
    Next iRow

End Sub

Upvotes: 1

Views: 202

Answers (2)

user3598756
user3598756

Reputation: 29421

beware relying on ActiveCell, it may not be what you'd expect to: you'd much better reference the range you know you have to start from

anyhow, assuming your ActiveCell is the header of a column with data following down below it, you could use AutoFilter() and sort of a "inverse" of filtered cells

Option Explicit

Sub Filter()
    Dim dataToKeep As Range
    Dim iArea As Long
    Dim words As Variant

    words = Array("AA", "BB", "CC", "DD", "EE", "FF", "GG", "HH", "XXX")

    With Range(ActiveCell, ActiveCell.End(xlDown))
        .AutoFilter Field:=1, Criteria1:=words, Operator:=xlFilterValues
        If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then
            Set dataToKeep = .SpecialCells(xlCellTypeVisible)
        Else
            .Offset(1).Resize(.Rows.Count - 1).EntireRow.Delete
        End If
        .Parent.AutoFilterMode = False
    End With
    If Not dataToKeep Is Nothing Then
        With dataToKeep.Areas
            If Intersect(.Item(.Count), ActiveCell.End(xlDown)) Is Nothing Then .Parent.Parent.Range(.Item(.Count).Cells(.Item(.Count).Rows.Count, 1).Offset(1), ActiveCell.End(xlDown)).EntireRow.Delete
            For iArea = .Count To 2 Step -1
                .Parent.Parent.Range(.Item(iArea).Cells(1, 1).Offset(-1), .Item(iArea - 1).Cells(.Item(iArea - 1).Rows.Count, 1).Offset(1)).EntireRow.Delete
            Next
        End With
    End If
End Sub

Upvotes: 2

YowE3K
YowE3K

Reputation: 23974

Just keep a Boolean variable saying whether you have matched any of the words:

Sub Filter()

    Dim i As Integer
    Dim word(1 To 20) As String
    Dim iRow As Integer, iCol As Integer
    Dim Matched As Boolean

    word(1) = "AA"
    word(2) = "BB"
    word(3) = "CC"
    word(4) = "DD"
    word(5) = "EE"
    word(6) = "FF"
    word(7) = "GG"
    word(8) = "HH"
    word(9) = "XXX"

    iCol = ActiveCell.Column

    For iRow = ActiveCell.End(xlDown).Row To 1 Step -1
        Matched = False
        For i = 1 To UBound(word) ' Note: This is 1 To 20, not 1 To 9
                                  '       positions 10 To 20 still exist even though
                                  '       they have not been assigned a value
            If Cells(iRow, iCol).Value = word(i) Then
                Matched = True
                Exit For
            End If
        Next i
        If Not Matched Then
            Rows(iRow).Delete
        End If
    Next iRow

End Sub

Upvotes: 3

Related Questions