Macro to delete rows with font strikeouts

[Guest]

I need to create a macro that will scan column A for any cells that contains
text with stikeouts and delete that entire row from the worksheet. My poor
example records manual keystokes but does not function.

Sub DeleteStikeouts()
'
Range("A1:A25").Select
With Application.FindFormat.Font
.Strikethrough = True
.Superscript = False
.Subscript = False
End With
Cells.Find(What:="", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext,
MatchCase:=False _
, SearchFormat:=True).Activate
Rows("3:3").Select
Selection.Delete Shift:=xlUp
Range("A3").Select
Cells.FindNext(After:=ActiveCell).Activate
End Sub

Steve

 

[Guest]

Hey, I don't know how your data is formatted, so if it's just one block of
data you can use this, if it's spread out, I can give you something for that
to, but this is the easiest way. LMK

Sub DeleteStrike()

Range("A1").Activate

Do Until ActiveCell.Value = ""

If ActiveCell.Font.Strikethrough = True Then
ActiveCell.EntireRow.Delete
Else: ActiveCell.Offset(1, 0).Activate
End If

Loop

End Sub

Change the starting Range to wherever your data starts.

 

[Dave Peterson]

If you look at VBA's help for .find, you'll see an example how to loop through
the range. When you find the topmost cell the second time, you know your loop
is finished and you've found all your cells.

But the bad news is that .findnext() doesn't remember the .findformat stuff.

But the good news is that you can just do another find--but after the previous
foundcell--just like your own version of .findnext().

Option Explicit
Sub DeleteStikeouts()

Dim myRng As Range
Dim DelRng As Range
Dim FoundCell As Range
Dim FirstAddress As String
Dim wks As Worksheet

Set wks = ActiveSheet

With wks
Set myRng = .Range("a1:a25")
End With

With Application.FindFormat.Font
.Strikethrough = True
.Superscript = False
.Subscript = False
End With

With myRng
Set FoundCell = .Cells.Find(what:="", _
after:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
lookat:=xlPart, _
searchorder:=xlByRows, _
searchdirection:=xlNext, _
MatchCase:=False, _
searchformat:=True)

If FoundCell Is Nothing Then
MsgBox "None found"
Else
FirstAddress = FoundCell.Address
Set DelRng = FoundCell
Do
Set FoundCell = .Cells.Find(what:="", _
after:=FoundCell, _
LookIn:=xlValues, _
lookat:=xlPart, _
searchorder:=xlByRows, _
searchdirection:=xlNext, _
MatchCase:=False, _
searchformat:=True)
If FoundCell.Address = FirstAddress Then
Exit Do
Else
Set DelRng = Union(DelRng, FoundCell)
End If
Loop
If DelRng Is Nothing Then
'this shouldn't happen
Else
DelRng.EntireRow.Select '.Delete 'when you're sure it worked
End If
End If
End With
End Sub


I used .select so you could verify that it was working--change it to .delete
when you're ready to test it out.

 

[Don Guillett]

I don't think findnext works with strikethrough so try

Sub DeleteStrikethrough()
For i = 1 to 25
If Cells(i, "a").Font.Strikethrough Then Rows(i).Delete
Next i
End Sub

 

[Jim Cone]

Keep in mind that Strikethrough can return Null for partially struck thru text.
--
Jim Cone
San Francisco, USA
http://www.realezsites.com/bus/primitivesoftware



"Steve" <[email protected]>
wrote in message
I need to create a macro that will scan column A for any cells that contains
text with stikeouts and delete that entire row from the worksheet. My poor
example records manual keystokes but does not function.

Sub DeleteStikeouts()
'
Range("A1:A25").Select
With Application.FindFormat.Font
.Strikethrough = True
.Superscript = False
.Subscript = False
End With
Cells.Find(What:="", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext,
MatchCase:=False _
, SearchFormat:=True).Activate
Rows("3:3").Select
Selection.Delete Shift:=xlUp
Range("A3").Select
Cells.FindNext(After:=ActiveCell).Activate
End Sub

Steve

 

[Guest]

Thank you, my worksheet is many columns wide and +1000 rows. All the macro
work great, didn't realize so many way to accomplish the task. Everyone,
thank you...

Steve