Delete all rows which doesn't contain certain text criteria (various criteria)

Try something like this. Remember to delete from the bottom up.

Please Login or Register  to view this content.

Hi, the problem with the filter is that I still have to filter them all out manually each week.

I'm just looking for some code I can set up and copy and paste into each week's file to delete all the rows except the ones I want.

Thanks

Originally Posted by maniacb

Try something like this. Remember to delete from the bottom up.

Please Login or Register  to view this content.

Hi thanks but it doesn't look like that one works, I have managed to delete some rows before but the problem comes when I need to insert around 60/70 versions of 'EGSA001' or 'AGTO003' into the code and I run out of space on the line.

I have managed to use the following below which doesn't run out of space, but it deletes the criteria instead of keeping the criteria stated. Any ideas on how to change this code to keep the rows - not delete them?

Sub Example1()

Dim varList As Variant
Dim lngarrCounter As Long
Dim rngFound As Range, rngToDelete As Range
Dim strFirstAddress As String

Application.ScreenUpdating = False

varList = VBA.Array("AAPC001", "DLPC001", "PCAA608", "PCAA609", "PCAA620", "PCAA621", "PCAA623", "PCAA624", "PCAA650", "PCAA651", "PCAA652", "PCCA608", "PCDB601", "PCDB602", "PCDL608", "PCDL609", "PCDL616", "PCDL617", "PCDL620", "PCDL621", "PCDL623", "PCDL624", "PCDL625", "PCDL650", "PCDL651", "PCDL652", "PCDL653", "PCES602", "PCES604", "PCES605", "PCHB001", "PCIC601", "PCIC602", "PCIC603", "PCIC604", "PCIC607", "PCIP604", "PCPC608", "PCPC611", "PCPC612", "PCPC613", "PCPC614", "PCPC615", "PCPC617", "PCPC618", "PCPD601", "PCPD602", "PCPI019", "PCPI609", "PCPI619", "PCPI623", "PCPI625", "PCPI650", "PCPI653", "PCPS601", "PCPS602", "PCPS603", "PCRM601", "PCRM602", "PCRP619", "PCRP620", "PCRP621", "PCRP623", "PCRP624", "PCRP625", "PCRP630", "PCRP631", "PCRP633", "PCRP634", "PCRP637", "PCRP638", "PCRP639", "PCWD601", "PCWD602")
For lngarrCounter = LBound(varList) To UBound(varList)

With Sheets("RP YTD").UsedRange
Set rngFound = .Find( _
What:=varList(lngarrCounter), _
Lookat:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=True)

If Not rngFound Is Nothing Then
strFirstAddress = rngFound.Address

If rngToDelete Is Nothing Then
Set rngToDelete = rngFound
Else
If Application.Intersect(rngToDelete, rngFound.EntireRow) Is Nothing Then
Set rngToDelete = Application.Union(rngToDelete, rngFound)
End If
End If

Set rngFound = .FindNext(After:=rngFound)

Do Until rngFound.Address = strFirstAddress
If Application.Intersect(rngToDelete, rngFound.EntireRow) Is Nothing Then
Set rngToDelete = Application.Union(rngToDelete, rngFound)
End If
Set rngFound = .FindNext(After:=rngFound)
Loop
End If
End With
Next lngarrCounter

If Not rngToDelete Is Nothing Then rngToDelete.EntireRow.Delete

Application.ScreenUpdating = True

End Sub

Originally Posted by AlphaFrog

Please Login or Register  to view this content.

Hi Alpha,

I'm afraid that just deleted the whole of the worksheet contents!

Originally Posted by AlphaFrog

It worked for me! Attach an example worksheet!

Not sure why I tried it a few times on mine!

I've finally cracked it anyway this did the job of what I needed to do...

Sub DeleteRows()
Dim List As Variant
Dim LR As Long
Dim r As Long
List = Array("AAPC001", "DLPC001", "PCAA608", "PCAA609", "PCAA620", "PCAA621", "PCAA623", "PCAA624", "PCAA650", "PCAA651", "PCAA652", "PCCA608", "PCDB601", "PCDB602", "PCDL608", "PCDL609", "PCDL616", "PCDL617", "PCDL620", "PCDL621", "PCDL623", "PCDL624", "PCDL625", "PCDL650", "PCDL651", "PCDL652", "PCDL653", "PCES602", "PCES604", "PCES605", "PCHB001", "PCIC601", "PCIC602", "PCIC603", "PCIC604", "PCIC607", "PCIP604", "PCPC608", "PCPC611", "PCPC612", "PCPC613", "PCPC614", "PCPC615", "PCPC617", "PCPC618", "PCPD601", "PCPD602", "PCPI019", "PCPI609", "PCPI619", "PCPI623", "PCPI625", "PCPI650", "PCPI653", "PCPS601", "PCPS602", "PCPS603", "PCRM601", "PCRM602", "PCRP619", "PCRP620", "PCRP621", "PCRP623", "PCRP624", "PCRP625", "PCRP630", "PCRP631", "PCRP633", "PCRP634", "PCRP637", "PCRP638", "PCRP639", "PCWD601", "PCWD602")
LR = Range("A" & Rows.Count).End(xlUp).Row
For r = LR To 1 Step -1
If IsError(Application.Match(Range("A" & r).Value, List, False)) Then
Rows(r).Delete
End If
Next r
End Sub

Thanks for the help by the way Alpha.

Originally Posted by ellbeardo

Not sure why I tried it a few times on mine!

I've finally cracked it anyway this did the job of what I needed to do...

Sub DeleteRows()
Dim List As Variant
Dim LR As Long
Dim r As Long
List = Array("AAPC001", "DLPC001", "PCAA608", "PCAA609", "PCAA620", "PCAA621", "PCAA623", "PCAA624", "PCAA650", "PCAA651", "PCAA652", "PCCA608", "PCDB601", "PCDB602", "PCDL608", "PCDL609", "PCDL616", "PCDL617", "PCDL620", "PCDL621", "PCDL623", "PCDL624", "PCDL625", "PCDL650", "PCDL651", "PCDL652", "PCDL653", "PCES602", "PCES604", "PCES605", "PCHB001", "PCIC601", "PCIC602", "PCIC603", "PCIC604", "PCIC607", "PCIP604", "PCPC608", "PCPC611", "PCPC612", "PCPC613", "PCPC614", "PCPC615", "PCPC617", "PCPC618", "PCPD601", "PCPD602", "PCPI019", "PCPI609", "PCPI619", "PCPI623", "PCPI625", "PCPI650", "PCPI653", "PCPS601", "PCPS602", "PCPS603", "PCRM601", "PCRM602", "PCRP619", "PCRP620", "PCRP621", "PCRP623", "PCRP624", "PCRP625", "PCRP630", "PCRP631", "PCRP633", "PCRP634", "PCRP637", "PCRP638", "PCRP639", "PCWD601", "PCWD602")
LR = Range("A" & Rows.Count).End(xlUp).Row
For r = LR To 1 Step -1
If IsError(Application.Match(Range("A" & r).Value, List, False)) Then
Rows(r).Delete
End If
Next r
End Sub

Does anybody know how I can extend the Array line on this? It lets me put about 85 of my criteria on a single line before it doesn't let me put anymore in. Is there a way of carrying on on the next line down.

Thanks,