Deleting all rows that do not contain a specified value in the Column D

The code below doesn't work because it constantly skips rows that should be deleted. I used to have a code that would search the defined range from the bottom up and that seemed to work. But even better would be if I could define a range as the entirerow of all cells in Range(top,btm) that don't equal str, and then delete that range of non-contigous cells al at once. That would be my preferred way of doing it.

How do I write that?

Thanks,
John
Sub DeleteIrrelevant1()
Application.ScreenUpdating = False
Dim top As Range, btm As Range, rng As Range, str As String
str = ActiveCell.Value
Set top = [D7]
Set btm = [D10000].End(xlUp)
Set rng = Range(top, btm)
For Each cel In rng
If cel <> str Then cel.EntireRow.Delete
Next cel
Application.ScreenUpdating = True
End Sub

Open in new window

LVL 1
John CarneyReliability Business Tools Analyst IIAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

krishnakrkcCommented:
Hi

Try this one

Sub DeleteIrrelevant1()
   
    Application.ScreenUpdating = False
    Dim top As Range, btm As Range, rng As Range, str As String
    Dim r As Range
   
    str = ActiveCell.Value
    Set top = [D7]
    Set btm = [D10000].End(xlUp)
    Set rng = Range(top, btm)
   
    With rng
        .AutoFilter 1, "<>" & str
        On Error Resume Next
        Set r = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(2)
        On Error GoTo 0
        If Not r Is Nothing Then r.EntireRow.Delete
        .AutoFilter
    End With
   
    Application.ScreenUpdating = True

End Sub


Kris
0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
wchhCommented:
try amended macro below:
Sub DeleteIrrelevant1()
Application.ScreenUpdating = False
Dim top As Range, btm As Range, rng As Range, str As String
str = ActiveCell.Value
'<---- Begin of Insert
Dim i As Long
i = 7
While i + d <= [D10000].End(xlUp).Row
    If Range("D" & i).Value <> str Then
        Rows(i).Delete
    Else
        i = i + 1
    End If
Wend
'<-----End of Insert
'Set top = [D7]
'Set btm = [D10000].End(xlUp)
'Set rng = Range(top, btm)

'For Each cel In rng
'    If cel <> str Then cel.EntireRow.Delete
'Next cel
Application.ScreenUpdating = True
End Sub

Open in new window

0
wchhCommented:
Sorry, this one more accurate...
Sub DeleteIrrelevant1()
Application.ScreenUpdating = False
Dim top As Range, btm As Range, rng As Range, str As String
str = ActiveCell.Value
'<---- Begin of Insert
Dim i As Long
i = 7
While i <= [D10000].End(xlUp).Row
    If Range("D" & i).Value <> str Then
        Rows(i).Delete
    Else
        i = i + 1
    End If
Wend
'<-----End of Insert
'Set top = [D7]
'Set btm = [D10000].End(xlUp)
'Set rng = Range(top, btm)

'For Each cel In rng
'    If cel <> str Then cel.EntireRow.Delete
'Next cel
Application.ScreenUpdating = True
End Sub

Open in new window

0
Microsoft Azure 2017

Azure has a changed a lot since it was originally introduce by adding new services and features. Do you know everything you need to about Azure? This course will teach you about the Azure App Service, monitoring and application insights, DevOps, and Team Services.

krishnakrkcCommented:
Hi,

In my code

replace

Set r = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(2)

with

Set r = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(12)

Kris
0
dlmilleCommented:
I personally prefer this approach, as I can do SELECT or something else besides DELETE.  The problem is traversing from top to bottom and deleting at the same time, you either have to go from bottom to top doing that, or just keep a range variable that accrues all the ranges to be deleted (my approach).  As a result, your code is only slightly modified:
 
Sub DeleteIrrelevant1()
Application.ScreenUpdating = False
Dim top As Range, btm As Range, rng As Range, str As String
dim rngToDelete as Range
str = ActiveCell.Value
Set top = [D7]
Set btm = [D10000].End(xlUp)
Set rng = Range(top, btm)
For Each cel In rng
If cel <> str Then 
  if rngtodelete is nothing then
     set rngtodelete = cel
  else
     set rngtodelete = union(rngtodelete,cel)
  end if
end if
Next cel

rngtodelete.entirerow.delete 'or select, or change colors/fonts, etc...
Application.ScreenUpdating = True
End Sub

Open in new window


enjoy!

Dave
0
John CarneyReliability Business Tools Analyst IIAuthor Commented:
I have a deadline on another project right now and as soon as I've finished it, I'll test these out.

Thanks for all the options. :-)
0
DaveCommented:
nice code Kris- very efficient.

Cheers

Dave
0
krishnakrkcCommented:
Hi,

Thanks Dave :)
0
dlmilleCommented:
Agreed
0
John CarneyReliability Business Tools Analyst IIAuthor Commented:
Sorry for being gone so long. Thank you both!

- John
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.