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]

Unfortunately, as you have found, that technique doesn't work if the cells contain "words" that start with a number.

 

[Fluff]

Try this instead

Sub DeleteRows()
   Dim FirstRow As Long
   Dim LastRow As Long
   Dim i As Long
   Dim Vr As Variant
   Dim Rng As Range
   Vr = Array("First Floor", "Entrance 1A", "Entrance 2D", "Main Office", "John's Office")
   With ActiveSheet
      FirstRow = .UsedRange.Cells(1).Row
      LastRow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
      For i = FirstRow To LastRow
         If InStr(1, "|" & Join(Vr, "|") & "|", "|" & .Cells(i, "D").Value & "|", vbTextCompare) = 0 Then
            If Rng Is Nothing Then Set Rng = Rows(i) Else Set Rng = Union(Rng, Rows(i))
         End If
      Next i
   End With
   If Not Rng Is Nothing Then Rng.Delete
End Sub

 

[Fluff]

Or, slightly simpler, as you're hardcoding the array

Sub DeleteRows()
   Dim FirstRow As Long
   Dim LastRow As Long
   Dim i As Long
   Dim Vr As String
   Dim Rng As Range
   Vr = "|First Floor|Entrance 1A|Entrance 2D|Main Office|John's Office|"
   With ActiveSheet
      FirstRow = .UsedRange.Cells(1).Row
      LastRow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
      For i = FirstRow To LastRow
         If InStr(1, Vr, "|" & .Cells(i, "D").Value & "|", vbTextCompare) = 0 Then
            If Rng Is Nothing Then Set Rng = Rows(i) Else Set Rng = Union(Rng, Rows(i))
         End If
      Next i
   End With
   If Not Rng Is Nothing Then Rng.Delete
End Sub

 

[Mux99]

Or, slightly simpler, as you're hardcoding the array

Sub DeleteRows()
   Dim FirstRow As Long
   Dim LastRow As Long
   Dim i As Long
   Dim Vr As String
   Dim Rng As Range
   Vr = "|First Floor|Entrance 1A|Entrance 2D|Main Office|John's Office|"
   With ActiveSheet
      FirstRow = .UsedRange.Cells(1).Row
      LastRow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
      For i = FirstRow To LastRow
         If InStr(1, Vr, "|" & .Cells(i, "D").Value & "|", vbTextCompare) = 0 Then
            If Rng Is Nothing Then Set Rng = Rows(i) Else Set Rng = Union(Rng, Rows(i))
         End If
      Next i
   End With
   If Not Rng Is Nothing Then Rng.Delete
End Sub

This works great. Thanks for all the help

 

[Fluff]

You're welcome & thanks for the feedback