• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 384
  • Last Modified:

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

0
John Carney
Asked:
John Carney
  • 3
  • 2
  • 2
  • +2
3 Solutions
 
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
 
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
Free Tool: Port Scanner

Check which ports are open to the outside world. Helps make sure that your firewall rules are working as intended.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

 
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
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

Join & Write a Comment

Featured Post

Get expert help—faster!

Need expert help—fast? Use the Help Bell for personalized assistance getting answers to your important questions.

  • 3
  • 2
  • 2
  • +2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now