PDA

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



Alan in NJ
01-16-2016, 10:31 AM
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




15193

jolivanes
01-16-2016, 02:00 PM
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
01-17-2016, 07:20 PM
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
01-18-2016, 03:14 AM
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
01-18-2016, 08:45 AM
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
01-18-2016, 09:06 AM
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
01-18-2016, 10:59 AM
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
01-18-2016, 01:27 PM
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
01-18-2016, 01:29 PM
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
01-18-2016, 02:13 PM
Add two lines

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

jolivanes
01-18-2016, 02:30 PM
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
01-18-2016, 03:12 PM
SamT can tell us for sure as he, I just assume that it is he, is a lot better at this than I am.
:rotflmao:

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
01-19-2016, 09:11 AM
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
01-19-2016, 01:16 PM
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
01-21-2016, 08:26 AM
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
01-29-2016, 09:22 AM
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
01-29-2016, 10:41 AM
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
01-29-2016, 11:39 AM
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
01-29-2016, 12:40 PM
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
01-29-2016, 01:10 PM
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

Alan in NJ
01-29-2016, 01:12 PM
Thanks jolivanes. Just noticed your reply. I'll try it.
Yes, I know about the timer code, but leaving it for testing.

jolivanes
01-29-2016, 04:49 PM
Put this at the beginning of your code. It'll delete all the empty cells.

Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row).SpecialCells(4).Delete Shift:=xlUp

Alan in NJ
01-30-2016, 09:11 AM
I can't get the code to change the background color to work. Also, I realized that I need code to move to the beginning of the range that is being considered for deletion, otherwise I can't see the cells and decide whether to delete them. Also, minor problem with blank cell deletion. I would appreciate your suggestions.


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

Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row).SpecialCells(4).Delete Shift:=xlUp
'I added the following line but if no empty cell found I get error message:
On Error Resume Next

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

'I added the following line, but it does not change the color (nor does "Selection.Interior.ColorIndex = 37"):
Range(Cells(rFound1.Row, 1), Cells(rFound2, 1)).Interior.ColorIndex = 37
Range(Cells(rFound1.Row, 1), Cells(rFound2, 1)).Select

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

SamT
01-30-2016, 12:15 PM
That is harder that it looks at first glance, or second. and even third study :D


This is designed to let you enter part of a word (ex "bio" ). it has a MsgBox to ask if you want to delete the block, if you click cancel, it will stop looking for that (partial) word and send you back to the Input Box. only when you click Cancel on the Input box, the sub will exit.


Sub VBAX_SAMT_Deletion()
Dim BottomCel As Range
Dim TopCel As Range
Dim DeleteRange As Range
Dim Temp As Range
Dim LastCel As Range
Dim TextToFind As String
Dim Answer As Long

AskForTextToFind:
TextToFind = InputBox(Title:="Text Block Deletion", Prompt:="Enter heading without underlinging or bold text")
If Len(TextToFind) = 0 Then GoTo GraceFulExit

Application.FindFormat.Font.Bold = True

Set LastCel = Cells(Rows.Count, 1).End(xlUp)
Set BottomCel = LastCel
If LastCel.Row < 2 Then MsgBox "What you want, Willis?"

Do
Set TopCel = Columns(1).Find(What:=TextToFind, SearchFormat:=True, LookIn:=xlValues, lookat:=xlPart, SearchDirection:=xlPrevious, After:=BottomCel)
' lookat:=xlPart,
If TopCel Is Nothing Then
MsgBox "'" & TextToFind & "'" & " was not found. Try a different word or phrase?"
GoTo AskForTextToFind
End If

If Not Temp Is Nothing Then
If TopCel.Offset(-1) = Temp Then GoTo AskForTextToFind 'because we've been here before
End If

If TopCel.Row > 1 Then
Set Temp = TopCel.Offset(-1, 0)
If Temp.Row > 1 And IsDate(Temp) Then Set Temp = Temp.Offset(-1)
Else
Set Temp = TopCel
End If

Set BottomCel = Columns(1).Find(What:="", SearchFormat:=True, LookIn:=xlValues, _
SearchDirection:=xlNext, After:=TopCel)

If BottomCel.Row < TopCel.Row Then 'Special case = delete bottom block
Set BottomCel = LastCel
Else
Set BottomCel = BottomCel.Offset(-1)
End If
If BottomCel = Temp Then GoTo AskForTextToFind 'Special case = ony one block left

Set DeleteRange = Range(TopCel, BottomCel)
DeleteRange.Interior.ColorIndex = 19
TopCel.Select

Answer = MsgBox(Prompt:="Delete this block of cells?", Buttons:=3, Title:="Text Block Deletion")
If Answer = 6 Then 'Yes
DeleteRange.Delete Shift:=xlShiftUp
ElseIf Answer = 2 Then
GoTo AskForTextToFind
Else
Cells.Interior.ColorIndex = xlColorIndexNone
End If
Set BottomCel = Temp
Loop

GraceFulExit:
Cells(1, 1).Select
Cells.Interior.ColorIndex = xlColorIndexNone
Application.FindFormat.Font.Bold = False 'I htink this line is right
End Sub



Notes:
Delete selected blocks

Constraints:
Some Blocks start with Bold, Green, Underlined Text
Some individual Rows have Bold, Purple Underlined Date
Some blocks contain Rows with Bold Font
Some Underlines <=> xlUnderlineStyleSingle (ignored for now)
Empty cells

Features:
(a) input box to specify the text of heading slated for deletion
(b) prior to each deletion, having the to-be-deleted cell highlighted and then have a message box appear with a prompt
(added) Allow multiple entries for deletion

Possible conditions:
To delete bottom block, do not set bottom cell of block to top cell of sheet
to delete top block, if top row of block is row 1 do not set tempcel to topcel offset -1
if Tempcel.row is row 1 this is last block to delete end loop.

Alan in NJ
01-30-2016, 12:53 PM
SamT: beautiful! I am playing with it now and will get back with any questions/possible tweeks, but so far looks like exactly what I need. Thank you and jolivanes both for sticking with me on this.

Alan in NJ
01-30-2016, 01:18 PM
I'm trying to decode how to get the "Willis" message. BTW, who's Willis?

SamT
01-30-2016, 01:37 PM
Run the code on an empty sheet.

The speaker to Willis is a character in an old sitcom.

Alan in NJ
01-30-2016, 03:06 PM
Yeah, I figured out Willis' purpose and found him.

Anyway . . . in my spreadsheet, bold alone does not define the first cell of a new range of related cells, i.e., some cells within a range may be bold (or underlined or a particular color). Rather, the cell after the end of a range (other than the last one which you have already covered with your code) comes in two flavors: (1) bold, underlined, Arial 11, green (RGB 0,102,0) (i.e., a new heading) or (2) if the range happens to be the last entry for a particular date, the following cell is the next day’s date in bold, underlined, Arial 14, purple (RGB 112,48,160). (See Book3 in #9 post above for example.) I added the conditions of underline and color to take care of (1), but is it possible to have an “or” for color in Application.Find.Font to take care of (2)? If not, or if it too difficult to code, I can change the colors of the dates to green and then change them back later.

I also temporarily removed the return to Cell (1,1) so that if I want to stop the search where I am because I noticed something that needs an edit I stay where I am.

Thanks, SamT.

SamT
01-30-2016, 04:06 PM
Off the top of my head

Set BottomCel = Columns(1).Find(What:="", SearchFormat:=True, LookIn:=xlValues, _
SearchDirection:=xlNext, After:=TopCel)
Do While Not( IsDate(BottomCel) Or BottomCel.Font.Color = RGB(0,102,0))
Set BottomCel = Columns(1).Find(What:="", SearchFormat:=True, LookIn:=xlValues, _
SearchDirection:=xlNext, After:=bottomCel)
Loop
If BottomCel.Row < TopCel.Row Then 'Special case = delete bottom block


I fergot some cells be bold and not headers

Alan in NJ
01-30-2016, 04:14 PM
It's otherwise: What makes headers unique is all three of: bold, underline and green (RGB 0, 102,0). Similarly, dates are unique due to all three of: bold, underline, and purple (RGB 112,48,160). Thanks.

SamT
01-30-2016, 05:35 PM
So you are saying that some cells have only dates in them, but they don't count

and some cells can be
Bold and Green, or
Bold and Underlined, or
Green and Underlined
but still not be headers?

Alan in NJ
01-31-2016, 07:08 AM
Answering second question first, yes that's correct. Only headings are all three: green, underlined AND bold.
As to the first question about the dates, I like the way you phrased the question as I hadn't thought of it that way. Yes, some cells contain a date in bold, underlined and purple (and, as with the headers, no other cells have all three) and if it is easy in the code to simply ignore them, that is, just leave them where they are, that's fine as they are never supposed to be deleted. I assume that would be easier to code than dealing with alternatives as I suggested. Again, I think the only instances when the dates create an issue is for the last entry (i.e., heading + text below it) for each date as that entry's end is not defined by a heading (the next heading appearing after the next day's date). Note that the spreadsheet is a chronological series of dates with headers and text as shown in my examples above.

One other question (and I don't want to impose on you so if this is non-trivial, please ignore it): would it be easy to add a "replace all" to the box so that if I found that all selections were proceeding smoothly I could at some point skip the one-by-one review?
Thanks much.

SamT
01-31-2016, 10:35 AM
I am trusting my instincts, rather than spend an hours parsing the logic, but
Option Explicit

Sub VBAX_SAMT_Deletion()
Dim BottomCel As Range
Dim TopCel As Range
Dim DeleteRange As Range
Dim Temp As Range
Dim LastCel As Range
Dim TextToFind As String
Dim Answer As Long

AskForTextToFind:
TextToFind = InputBox(Title:="Text Block Deletion", Prompt:="Enter heading without underlinging or bold text")
If Len(TextToFind) = 0 Then GoTo GraceFulExit

Application.FindFormat.Font.Bold = True

Set LastCel = Cells(Rows.Count, 1).End(xlUp)
Set BottomCel = LastCel
If LastCel.Row < 2 Then MsgBox "What you want, Willis?"

Do
Set TopCel = Columns(1).Find(What:=TextToFind, SearchFormat:=True, LookIn:=xlValues, lookat:=xlPart, SearchDirection:=xlPrevious, After:=BottomCel)
' lookat:=xlPart,
If TopCel Is Nothing Then
MsgBox "'" & TextToFind & "'" & " was not found. Try a different word or phrase?"
GoTo AskForTextToFind
End If
'''''''''''''''''''''''''''''''''''''''
Do While Not (IsDate(TopCel)) _
Or TopCel.Font.Color <> RGB(0, 102, 0) _
Or TopCel.Font.Bold <> True
Set TopCel = Columns(1).Find(What:="", SearchFormat:=True, LookIn:=xlValues, _
SearchDirection:=xlPrevious, After:=TopCel)
Loop
'''''''''''''''''''''''''''''''''''''''
If Not Temp Is Nothing Then
If TopCel.Offset(-1) = Temp Then GoTo AskForTextToFind 'because we've been here before
End If

If TopCel.Row > 1 Then
Set Temp = TopCel.Offset(-1, 0)
If Temp.Row > 1 And IsDate(Temp) Then Set Temp = Temp.Offset(-1)
Else
Set Temp = TopCel
End If

Set BottomCel = Columns(1).Find(What:="", SearchFormat:=True, LookIn:=xlValues, _
SearchDirection:=xlNext, After:=TopCel)
''''''''''''''''''''''''''''''''''''''''''''''''
Do While Not (IsDate(BottomCel)) _
Or BottomCel.Font.Color <> RGB(0, 102, 0) _
Or BottomCel.Font.Bold <> True
Set BottomCel = Columns(1).Find(What:="", SearchFormat:=True, LookIn:=xlValues, _
SearchDirection:=xlNext, After:=BottomCel)
Loop
''''''''''''''''''''''''''''''''''''''''''''''''''
If BottomCel.Row < TopCel.Row Then 'Special case = delete bottom block
Set BottomCel = LastCel
Else
Set BottomCel = BottomCel.Offset(-1)
End If
If BottomCel = Temp Then GoTo AskForTextToFind 'Special case = ony one block left

Set DeleteRange = Range(TopCel, BottomCel)
DeleteRange.Interior.ColorIndex = 19
TopCel.Select

Answer = MsgBox(Prompt:="Delete this block of cells?", Buttons:=3, Title:="Text Block Deletion")
If Answer = 6 Then 'Yes
DeleteRange.Delete Shift:=xlShiftUp
ElseIf Answer = 2 Then
GoTo AskForTextToFind
Else
Cells.Interior.ColorIndex = xlColorIndexNone
End If
Set BottomCel = Temp
Loop

GraceFulExit:
Cells(1, 1).Select
Cells.Interior.ColorIndex = xlColorIndexNone
Application.FindFormat.Font.Bold = False 'I htink this line is right
End Sub




One other question (and I don't want to impose on you so if this is non-trivial, please ignore it): would it be easy to add a "replace all" to the box so that if I found that all selections were proceeding smoothly I could at some point skip the one-by-one review?
A MsgBox is limited to 3 buttons and we are already using all three. You would need a UserForm to get 4 buttons, but it can be done. You will need a module level variable for Answer, the UserForm would set Answer and the if Answer = "Do All" or it's numeric equivalent, skip the message. Reset Answer to 0 or empty after the AskForTextToFind Line Label.

Alan in NJ
01-31-2016, 10:44 AM
Thanks SamT for all of your help. I'll work with the above this afternoon.

Aussiebear
01-31-2016, 03:29 PM
The speaker to Willis is a character in an old sitcom.

So, this not one of your alter egos then???

SamT
01-31-2016, 04:16 PM
Are you sayin' that I are funny? :bat2:

Aussiebear
01-31-2016, 11:45 PM
Just putting it out there mate

SamT
02-01-2016, 08:57 AM
:motz2:






















:beerchug:

Alan in NJ
02-03-2016, 10:33 AM
SamT, if you have another minute . . . I have been refining your code with my limited excel vba capabilities. It worked very reliably so I now have it clearing the heading and related text automatically for all instances of a heading without the need for highlighting and then my review and approval. By changing the delete and shift up to only clearing, when I start the process I put in column B a complete copy of the original column A and then browse through after the fact to make sure there was nothing deleted that I wanted left in. The last change I made (and that I want to ask you about) is I added code that lets me put a list of headings in a table in a spreadsheet called, duh, "Headings" and then let the code run and delete everything automatically.

It works BUT sometimes I get a "script out of range" error on the line: Set tbl = Worksheets("Headings").ListObjects("Table1"). I suspect this is a minor error in my use of the table, but I am at a loss would appreciate you help. I left a lot of the deleted code in case I need to refer to it.


Sub Auto_Header_Delete()

Dim tbl As ListObject
Dim x As Long
Dim BottomCel As Range
Dim TopCel As Range
Dim DeleteRange As Range
Dim Temp As Range
Dim LastCel As Range
Dim TextToFind As String
Dim Answer As Long


Application.FindFormat.Clear
Application.ReplaceFormat.Clear
Application.FindFormat.Font.Bold = True
Application.FindFormat.Font.Underline = xlSingle
Application.FindFormat.Font.Color = RGB(0, 102, 0)

'''''''''''''''''''''''''''''''''''''''''''''''''''''


Set tbl = Worksheets("Headings").ListObjects("Table1") 'this is where I sometimes get the error

'Loop Through Every Row in Table
For x = 2 To tbl.Range.Rows.Count
TextToFind = Worksheets("Headings").Cells(x, "A").Value

''''''''''''''''''''''''''''''''''''''''''''''''''''''

'AskForTextToFind:
'TextToFind = InputBox(Title:="Text Block Deletion", prompt:="Enter heading without underlinging or bold text")
If Len(TextToFind) = 0 Then GoTo GraceFulExit


Set LastCel = Cells(Rows.Count, 1).End(xlUp)
Set BottomCel = LastCel
If LastCel.Row < 2 Then MsgBox "What you want, Willis?"

Do
Set TopCel = Columns(1).Find(What:=TextToFind, SearchFormat:=True, LookIn:=xlValues, lookat:=xlPart, SearchDirection:=xlPrevious, After:=BottomCel)
' lookat:=xlPart,
If TopCel Is Nothing Then
'MsgBox "'" & TextToFind & "'" & " was not found. Try a different word or phrase?"
GoTo AskForTextToFind

End If

If Not Temp Is Nothing Then
If TopCel.Offset(-1) = Temp Then GoTo AskForTextToFind 'because we've been here before
End If

If TopCel.Row > 1 Then
Set Temp = TopCel.Offset(-1, 0)
If Temp.Row > 1 And IsDate(Temp) Then Set Temp = Temp.Offset(-1)
Else
Set Temp = TopCel
End If

Set BottomCel = Columns(1).Find(What:="", SearchFormat:=True, LookIn:=xlValues, _
SearchDirection:=xlNext, After:=TopCel)

If BottomCel.Row < TopCel.Row Then 'Special case = delete bottom block
Set BottomCel = LastCel
Else
Set BottomCel = BottomCel.Offset(-1)
End If
If BottomCel = Temp Then GoTo AskForTextToFind 'Special case = ony one block left

Set DeleteRange = Range(TopCel, BottomCel)
'DeleteRange.Interior.ColorIndex = 19
'TopCel.Select

'Answer = MsgBox(prompt:="Delete this block of cells?", Buttons:=3, Title:="Text Block Deletion")
'If Answer = 6 Then 'Yes
DeleteRange.ClearContents

'ElseIf Answer = 2 Then
'GoTo AskForTextToFind
'Else
'Cells.Interior.ColorIndex = xlColorIndexNone
'End If
Set BottomCel = Temp
Loop

GraceFulExit:
'Cells(1, 1).Select
Cells.Interior.ColorIndex = xlColorIndexNone
Application.FindFormat.Font.Bold = False 'I htink this line is right


AskForTextToFind:

Next x

End Sub

SamT
02-03-2016, 11:15 AM
List Objects are designed to work with PowerPivot Tables, (an App for use with Databases,) so Excel is having to guess what you mean.

You can try this, but I have no, zero, zilch experience with ListObjects.
Set Table1 = Worksheets("Headings").ListObjects.Add(SourceType:=xlSrcRange, _
Source:=Range("A1:Z26"), TableStyleName:=0)

Set tbl = Worksheets("Headings").ListObjects("Table1")

However, all you are trying to do is set Tbl to an undefined range

Set tbl = Worksheets("Headings").Range("A1").CurrentRegion
'assumes Range("A1") is a Cell included in the table

Alan in NJ
02-03-2016, 12:02 PM
Thanks for reply, I'll give it a try. I lifted the references to ListObjects from some other code I had that used a two column table to find col A and replace with Col B.
All I really need to do here is loop through each cell in col A of Spreadsheet("Heading") setting TextToFind to the value of cell, so the ListObjects is prob. not necessary.