Use Find Method to Clear Groups of Cells in Column When First Cell Marked "DELETE"

[Alan in NJ]

I have a 55,000 row single-column spreadsheet containing text (sample attached). The basic format is a heading row (in bold, green, underlined text) followed by one or more rows (single cells in column A) of text under that heading, followed by the next heading, and rows of text, etc. I am editing this spreadsheet to clear and then delete some of these headings along with the rows of text that follow it. Prior to running the VBA code that I am having trouble creating, I will have replaced the heading rows that need to be deleted with the word "DELETE".

I first worked on the code that is set off in the middle below that allows me to select a cell marked "DELETE" and then run the macro to clear it and the lines below it down to the next heading. That seems to work, but given the size of the spreadsheet I would like to automate this. Any help would be appreciated. (sorry code below is not formatted properly, I don't know how to do it)

Alan

Sub DeletionMacro()
Dim oRange As Range, aCell As Range
      Dim ws As Worksheet
      Dim SearchString As String
On Error GoTo What
Set ws = Worksheets("Sheet1")
      Set oRange = ws.Columns(1)
SearchString = "DELETE"
Set aCell = oRange.Find(What:=SearchString, LookIn:=xlValues, _
                  LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                  MatchCase:=True, SearchFormat:=False)
If Not aCell Is Nothing Then
      Set stcell = ActiveCell
Application.FindFormat.Clear
With Application.FindFormat.Font
          .Name = "Arial"
          .FontStyle = "Bold"
          .Size = 11
          .Strikethrough = False
          .Superscript = False
          .Subscript = False
          .Underline = xlUnderlineStyleSingle
          .Color = 26112
          .TintAndShade = 0
          .ThemeFont = xlThemeFontNone
      End With
Cells.Find(What:="?", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
          xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:= _
          False, SearchFormat:=True).Activate
ActiveCell.Offset(-1, 0).Select
Set rg = Range(ActiveCell, stcell)
rg.Select
Selection.Clear
Application.FindFormat.Clear
End If
Do Until aCell Is Nothing
Set aCell = oRange.FindNext(After:=aCell)
      Loop
What:
      MsgBox Err.Description
  End Sub

Book2.xlsx

[jolivanes]

To put code tags around code, select your code and click on the pound (#) sign or
put an opening square bracket followed by the word code and closing square bracket just before the start of your code and an opening square bracket followed by a forward slash (/), the word code and a closing square bracket.
Like this but without the spaces. [ code] and [/ code]

[jolivanes]

No one has come with code yet so you could try this on a copy of your workbook if you'd like.

Sub Try_This_Maybe()
Dim rwArr1, rwArr2, i As Long, ii As Long, j As Long, k As Long
Dim rFound1 As Range, lr As Long, c As Range


lr = Cells(Rows.Count, 1).End(xlUp).Row
ii = 1
j = Application.WorksheetFunction.CountIf(Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row), "DELETE")


ReDim rwArr1(0 To j - 1)
ReDim rwArr2(0 To j - 1)


For i = 1 To j
    Set rFound1 = Columns(1).Find(What:="DELETE", After:=Cells(ii, 1), LookIn:=xlValues)
rwArr1(i - 1) = rFound1.Row


For Each c In Range(Cells(rFound1.Row + 1, 1), Cells(lr, 1))
    If c.Font.Bold = True Then rwArr2(i - 1) = c.Row - 1: Exit For
Next c


ii = rFound1.Row + 1
Next i


For k = LBound(rwArr1) To UBound(rwArr1)
    Range(Cells(rwArr1(k), 1), Cells(rwArr2(k), 1)).ClearContents
Next k


Range(Cells(1, 1), Cells(lr, 1)).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
End Sub

[SamT]

Sub VBAX_SAMT_Deletion()
Dim BottomCel As Range
Dim TopCel As Range
Dim Temp

Application.FindFormat.Font.Bold = True
        

Set BottomCel = Cells(Rows.Count, 1).End(xlUp)
Do
  Set TopCel = Columns(1).Find(What:="", SearchFormat:=True, LookIn:=xlValues, SearchDirection:=xlPrevious, After:=BottomCel)
  If TopCel.Row = 1 Then Exit Do 'Range("A1") must be Bold and <> "delete"
  Set Temp = TopCel.Offset(-1, 0)
  If LCase(TopCel) = "delete" Then Range(TopCel, BottomCel).Delete Shift:=xlShiftUp
  Set BottomCel = Temp
Loop

End Sub

[Alan in NJ]

Thanks to jolivanes and SamT; both suggestions seem to work great on the sample spreadsheet. I will test further on my large spreadsheet and post results. Again, I am very appreciative that you both responded to my post.
Alan

[jolivanes]

Another one to try.

Sub With_Looping()
Dim c As Range, cel As Range, rFound1 As Range, rFound2 As Long, ttl As Long, j As Long
    ttl = Application.WorksheetFunction.CountIf(Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row), "DELETE")
    Application.ScreenUpdating = False
    For j = 1 To ttl
    Set c = Range("A:A")
    Set rFound1 = c.Find(what:="DELETE", after:=c(1), searchdirection:=xlPrevious)
        For Each cel In Range(Cells(rFound1.Row + 1, 1), Cells(rFound1.End(xlDown).Row, 1))
            If cel.Font.Bold = True Then rFound2 = cel.Row - 1: Exit For
        Next cel
        Range(Cells(rFound1.Row, 1), Cells(rFound2, 1)).Delete Shift:=xlUp
    Next j
    Application.ScreenUpdating = True
End Sub

[jolivanes]

You might have found out in the meantime but if you add Application.Screenupdating = False / = True to SamT's code, that is the one to use.
If you run the first one, Post #3, you might as well go for a long lunch while it runs.
I tested all three with 9920 lines of data with 7040 lines of data left after the code is finished.
Post #3 code takes 95.5 seconds
Post #6 code takes 65.2 seconds
Post #4 code takes 60.2 seconds without ScreenUpdating
Post #4 code takes 45.1 seconds with ScreenUpdating

[SamT]

Hint for the future: When using these Onetime routines, as soon as it works on your short sample of data, quickly press F5 twice more.

VBA uses an iterative compiler that recompiles the code for more efficiency the first few times it runs.

[Alan in NJ]

jolivanes:

I am working with your solution which, as you wrote it, addresses one of two variations on my spreadsheet that I neglected to include in the sample I uploaded. Variation 1: In some cases, the range of rows below the "DELETE" heading row (and therefore rows that need to be deleted) will be followed by a row containing a date in bold, underlined, purple font (see spreadsheet unloaded with this post). Your code correctly ends the deletion on the prior row, I believe because it searched for the next instance of bold font and then backs up one row. Variation 2: One of the rows below the "DELETE" heading row that should be deleted may contain bold font, and therefore it would trigger the end of the range when it shouldn't (example is on attached spreadsheet).

To deal with Variation 2, I edited "If c.Font.Bold = True" by adding "And c.Font.Underline = True" and then tried "And c.Font.Underline =xlUnderlineStyleSingle" but neither would work. If you wouldn't mind revisiting your code to deal with this, I would very much appreciate it.

Alan

[SamT]

Add two lines

Do While Not IsDate(TopCel)
Set TopCel = Columns(1).Find(What:="", SearchFormat:=True, LookIn:=xlValues, SearchDirection:=xlPrevious, After:=BottomCel)
Loop

[jolivanes]

Alan.
How did you change to "DELETE"?
Would it not be better to have this as part of the code? After all, you mentioned in Post #1 that you have +/- 55,000 rows to deal with.


The Row(s) with a Date in it, do they just need deleting?


Do you have anything in Columns B, C, D etc. I have such an idea that Filtering might be faster. SamT can tell us for sure as he, I just assume that it is he, is a lot better at this than I am.


For your variation #2 you might need something like this:

If c.Font Bold = True And c.Font.Underline = xlUnderlineStyleSingle = True Then

@SamT
Never heard of or seen the "Hint for the future" before.
Have to figure that out.
Thanks

[SamT]

SamT can tell us for sure as he, I just assume that it is he, is a lot better at this than I am.

VBA is just a hobby for me. I was a Carpenter/Contractor.
Wait. I did once earn a Trinidad dollar for some code I wrote. Maybe I are a Pro.

[jolivanes]

You could try this. Just check that the ColorIndex of your green/bold/underlined cells is 10.

Sub With_Looping()
Dim c As Range, cel As Range, rFound1 As Range, rFound2 As Long, ttl As Long, j As Long, t
    ttl = Application.WorksheetFunction.CountIf(Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row), "DELETE")
    t = Timer
    Application.ScreenUpdating = False
    For j = 1 To ttl
    Set c = Range("A:A")
    Set rFound1 = c.Find(What:="DELETE", After:=c(1), SearchDirection:=xlPrevious)
    
        For Each cel In Range(Cells(rFound1.Row + 1, 1), Cells(rFound1.End(xlDown).Row, 1))
            With cel.Font
                If .Bold = True And .Underline = xlUnderlineStyleSingle = True And .ColorIndex = 10 Then rFound2 = cel.Row - 1: Exit For
            End With
        Next cel
   
        Range(Cells(rFound1.Row, 1), Cells(rFound2, 1)).Delete Shift:=xlUp
    Next j
    Cells(Rows.Count, 10).End(xlUp).Offset(1) = "This macro took " & Format(Round(Timer - t, 2), "00:00:00.00") & " seconds to run."
    Application.ScreenUpdating = True
End Sub

@SamT
You say "was"
Are you a well deserved retiree?

[SamT]

Sumpin like dat.

@ Alan
I misread your Post in re the date cell

Sub VBAX_SAMT_Deletion() 
    Dim BottomCel As Range 
    Dim TopCel As Range 
    Dim Temp 
     
    Application.FindFormat.Font.Bold = True 
     
    Set BottomCel = Cells(Rows.Count, 1).End(xlUp) 
    Do 
        Set TopCel = Columns(1).Find(What:="", SearchFormat:=True, LookIn:=xlValues, SearchDirection:=xlPrevious, After:=BottomCel) 
        If TopCel.Row = 1 Then Exit Do 'Range("A1") must be Bold and <> "delete"


        If IsDate(TopCel) Then
         If LCaseTopCel,Offset(-1)) = "delete" Then Set TopCel = TopCel.Offset(-1)
        End If

        Set Temp = TopCel.Offset(-1, 0) 

        If LCase(TopCel) = "delete" Then Range(TopCel, BottomCel).Delete Shift:=xlShiftUp 
        Set BottomCel = Temp 
    Loop 
     
GraceFulExit:
Application.FindFormat.Font.Bold = False 'I htink this line is right
End Sub

[Alan in NJ]

I had to put this project aside for a couple of days, but I didn't want to delay in thanking both of you for the further suggestions. I will review and test them during our snow storm on Saturday.
Alan

[Alan in NJ]

Hi guys. I'm working with jolivanes' latest in post #13 above and modifying the conditions that determine the bottom of the deletion range. I'm not sure I explained it clearly, but the bottom of the range that begins with the "DELETE" cell is either the next bold, green, underlined heading OR the next bold, purple, underlined date. (This obviously occurs when the lines slated for deletion are the last entries for a particular day.) So I modified the relevant line and it seems to be working.

Many thanks to you both again and I hope I will see responses from you if I post with further problems. Thanks.

Alan

[Alan in NJ]

Also, I'm working on adding two refinements: (a) input box to specify the text of heading slated for deletion (so that changing headings to "DELETE" in advance would not be necessary) and (b) prior to each deletion, having the to-be-deleted cell highlighted and then have a message box appear with a prompt ("Do you want to delete these cells or skip them"). As much as I want this to automated, some of the headings and their associated cells will need some scrutiny by me.

(a) was easy, but any suggestions on (b) would be appreciated.

Alan

[Alan in NJ]

I think I've gotten both (a) and (b) above to work with the code below, with one issue: I want the background of the selected cells to to be highlighted so I can determine whether to proceed to delete them or not, but I can't get the code right. Any suggestions would be appreciated.

Alan

Sub With_Looping_with_message_boxoption2()
    Dim c As Range, cel As Range, rFound1 As Range, rFound2 As Long, ttl As Long, j As Long, t
    Dim heading As String, yn As String, q As String
    
    q = "Delete these cells?"
    heading = InputBox("Enter heading without underlinging or bold text")
    
    
    
    ttl = Application.WorksheetFunction.CountIf(Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row), heading)
    t = Timer
    Application.ScreenUpdating = False
    For j = 1 To ttl
        Set c = Range("A:A")
        Set rFound1 = c.Find(What:=heading, After:=c(1), SearchDirection:=xlPrevious)
         
        For Each cel In Range(Cells(rFound1.Row + 1, 1), Cells(rFound1.End(xlDown).Row, 1))
            With cel.Font
                If .Bold = True And .Underline = xlUnderlineStyleSingle = True And (.ColorIndex = 10 Or .ColorIndex = 29 Or .Color = RGB(112, 48, 160)) Then rFound2 = cel.Row - 1: Exit For
            End With
        Next cel
         
        Range(Cells(rFound1.Row, 1), Cells(rFound2, 1)).Select
        
        'MY PROBLEM IS HERE:
        With Selection.Interior.ColorIndex = 37
        End With
        
 
        yn = MsgBox(q, vbYesNo)
        If yn = vbYes Then
        
        Selection.Delete Shift:=xlUp
    
        Else
        With Selection.Interior.ColorIndex = 0
        End With
 
        End If
    
    Next j
   
    Application.ScreenUpdating = True
End Sub

[jolivanes]

This

    With Selection
        .Interior.ColorIndex = 37
    End With

or this

 Selection.Interior.ColorIndex = 37

should do the trick
But if possible, stay away from selecting.
Wouldn't this do what you want?

Range(Cells(rFound1.Row, 1), Cells(rFound2, 1)).Interior.ColorIndex = 37

BTW, you can leave the references to the timer out. I had these in to see how slow/fast the code was.

[Alan in NJ]

I continue testing with the following code which is the code above (including the input box to specify the heading) but without the message box that stops to ask if the deletion should be made. It seems to work great (thanks guys) with only issue being that if there is a blank cell under one of the heading being deleted large chunks of cells that should have remained are deleted. I continue testing.

Alan

Sub With_Looping_with_message_box()
    Dim c As Range, cel As Range, rFound1 As Range, rFound2 As Long, ttl As Long, j As Long, t
    Dim heading As String
    
    heading = InputBox("Enter heading without underlinging or bold text")
    
    
    
    ttl = Application.WorksheetFunction.CountIf(Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row), heading)
    t = Timer
    Application.ScreenUpdating = False
    For j = 1 To ttl
        Set c = Range("A:A")
        Set rFound1 = c.Find(What:=heading, After:=c(1), SearchDirection:=xlPrevious)
         
        For Each cel In Range(Cells(rFound1.Row + 1, 1), Cells(rFound1.End(xlDown).Row, 1))
            With cel.Font
                 If .Bold = True And .Underline = xlUnderlineStyleSingle = True And  (.ColorIndex = 10 Or .ColorIndex = 29 Or .Color = RGB(112, 48, 160))  Then rFound2 = cel.Row - 1: Exit For
            End With
        Next cel
         
        Range(Cells(rFound1.Row, 1), Cells(rFound2, 1)).Delete Shift:=xlUp
    Next j
     Cells(Rows.Count, 10).End(xlUp).Offset(1) = "This macro took " &  Format(Round(Timer - t, 2), "00:00:00.00") & " seconds to run."
    Application.ScreenUpdating = True
End Sub