Not detecting all arrays

[Mux99]

I'm using the code below to delete all rows that don't contain a list of words. For some reason it is deleting the cell that contains the word Apple and keeps the other three with Banana, Orange & Apple Tree. Hopefully someone can help me out.

Also is it possible to search for Apple and automatically detect all cells containing that word? Ex. Apple, Apple Tree etc...

Sub DeleteRows() Dim FirstRow As Long
Dim LastRow As Long
Dim Lrow As Long
Dim Testt As Variant
Testt = Array("Banana", "Apple", "Orange", "Apple Tree")
With ActiveSheet
.Select
FirstRow = .UsedRange.Cells(1).Row
LastRow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
For Lrow = LastRow To FirstRow Step -1
With .Cells(Lrow, "D")
If Not UBound(filter(Testt, .Value, True, vbTextCompare)) = 0 Then .EntireRow.Delete
End With
Next Lrow
End With
End Sub

 

[Fluff]

Try

If UBound(Filter(Testt, .Value, True, vbTextCompare)) >= 0 Then .EntireRow.Delete

 

[Fluff]

To delete rows where the cell contains a value in the array try

Sub Mux99()
   Dim Cl As Range, Rng As Range
   Dim i As Long
   Dim Ary As Variant
   
   Ary = Array("Banana", "Apple", "Orange")
   For Each Cl In Range("D2", Range("D" & Rows.Count).End(xlUp))
      For i = 0 To UBound(Ary)
         If InStr(1, Cl, Ary(i), 1) > 0 Then
            If Rng Is Nothing Then Set Rng = Cl Else Set Rng = Union(Rng, Cl)
            Exit For
         End If
      Next i
   Next Cl
   If Not Rng Is Nothing Then Rng.EntireRow.Delete
End Sub

 

[Mux99]

Try

If UBound(Filter(Testt, .Value, True, vbTextCompare)) >= 0 Then .EntireRow.Delete

This fixed the issue. Thanks

To delete rows where the cell contains a value in the array try

Sub Mux99()
   Dim Cl As Range, Rng As Range
   Dim i As Long
   Dim Ary As Variant
   
   Ary = Array("Banana", "Apple", "Orange")
   For Each Cl In Range("D2", Range("D" & Rows.Count).End(xlUp))
      For i = 0 To UBound(Ary)
         If InStr(1, Cl, Ary(i), 1) > 0 Then
            If Rng Is Nothing Then Set Rng = Cl Else Set Rng = Union(Rng, Cl)
            Exit For
         End If
      Next i
   Next Cl
   If Not Rng Is Nothing Then Rng.EntireRow.Delete
End Sub

This one almost worked, it did the opposite of what I needed. I wanted to keep the rows containing the array and delete all other rows.

I'm wondering if it's possible to search for a mix of arrays, a few keywords like the above and some that have to be a perfect match?

 

[Fluff]

can you please post some (realistic) examples of your data & what you need.

 

[Mux99]

can you please post some (realistic) examples of your data & what you need.

I decided to stick with the first code that uses perfect match to avoid mistakes since some of the keywords I will be using are similar. Thanks for the help

 

[Mux99]

The below is almost working perfectly for what I need. It deletes all rows that don't contain the exact keywords in column D. There are some cells in column D with the word "OFF" in it and it is not deleting those rows for some reason. Any ideas?

Sub DeleteRows()
Dim FirstRow As Long
Dim LastRow As Long
Dim Lrow As Long
Dim Vr As Variant
Vr = Array("Second Floor", "Back Entrance", "Front Entrance", "Main Office")
With ActiveSheet
.Select
FirstRow = .UsedRange.Cells(1).Row
LastRow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
For Lrow = LastRow To FirstRow Step -1
With .Cells(Lrow, "D")
If Not UBound(Filter(Vr, .Value, True, vbTextCompare)) >= 0 Then .EntireRow.Delete
End With
Next Lrow
End With
End Sub

 

[Fluff]

Filter looks for partial matches, so because OFF is in Office, it wont be deleted.

 

[Fluff]

How about

Sub DeleteRows()
   Dim FirstRow As Long
   Dim LastRow As Long
   Dim i As Long
   Dim Vr As Variant
   Vr = Array("Second Floor", "Back Entrance", "Front Entrance", "Main Office")
   With ActiveSheet
      FirstRow = .UsedRange.Cells(1).Row
      LastRow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
      With .Range("D" & FirstRow & ":D" & LastRow)
         For i = 0 To UBound(Vr)
            .Replace Vr(i), "=XXX" & Vr(i), xlWhole, , False, , False, False
         Next i
         .SpecialCells(xlConstants).EntireRow.Delete
         .Replace "=XXX", "", xlPart, , False, , False, False
      End With
   End With
End Sub

 

[Mux99]

How about

Sub DeleteRows()
   Dim FirstRow As Long
   Dim LastRow As Long
   Dim i As Long
   Dim Vr As Variant
   Vr = Array("Second Floor", "Back Entrance", "Front Entrance", "Main Office")
   With ActiveSheet
      FirstRow = .UsedRange.Cells(1).Row
      LastRow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
      With .Range("D" & FirstRow & ":D" & LastRow)
         For i = 0 To UBound(Vr)
            .Replace Vr(i), "=XXX" & Vr(i), xlWhole, , False, , False, False
         Next i
         .SpecialCells(xlConstants).EntireRow.Delete
         .Replace "=XXX", "", xlPart, , False, , False, False
      End With
   End With
End Sub

This worked with that worksheet but when I tried it with another one with different keywords it deleted some of the arrays with numbers included. Ex.

Vr = Array("First Floor", "Entrance 1A", "Entrance 2D", "Main Office, John's Office")

With the above it only detected First Floor & Main Office and deleted the rows with numbers and symbols in them.