Macro to delete everything below the header depending on the specific text but don't delete the header

[tropics123]

Hi! Could someone help me tweak this macro? I want the macro to find specific texts in the header and (the text will appear multiple times) and delete everything in that column but don't delete the header. For example, I want the macro to look for "Mary Lee" and "Bob Smith" in the header and delete everything in the column below Mary Lee and Bob Smith's name but leave Mary Lee and Bob Smith's name in the header.

This is the before table:

Mary Lee	Bob Smith	Luke Skywalker	Mary Lee	Bob Smith	Mary Lee	Joe Watson
$450	$2000	$90	$78	$88	$67	$23
$57	$709	$19	$59	$39	$78	$587
$98	$39	$35	$56	$28	$55	$6560

<tbody>
</tbody>

After:

Mary Lee	Bob Smith	Luke Skywalker	Mary Lee	Bob Smith	Mary Lee	Joe Watson
		$90				$23
		$19				$587
		$35				$6560

<tbody>
</tbody>

Here's my macro but it's deleting everything in the column including the header. Thank you for your help!

Sub Delete()


' Delete cells below header with specific text but don't delete header
Sheets("Sheet3").Select
Dim A As Range



Do
Set A = Rows(1).Find(What:="Mary Lee", LookIn:=xlValues, lookat:=xlPart)
Set A = Rows(1).Find(What:="Bob Smith", LookIn:=xlValues, lookat:=xlPart)
If A Is Nothing Then Exit Do
A.EntireColumn.Delete
Loop
End Sub

 

[JoeMo]

Assumes headers are in row 1.

Sub RemoveAllBelowHeader()
'assumes all headers are in row 1
Dim tgtHdrs As Variant, Fnd As Range, fAdr As String
tgtHdrs = Array("Mary Lee", "Bob Smith") ' headers to remove data below the header,change to suit
Application.ScreenUpdating = False
For i = LBound(tgtHdrs) To UBound(tgtHdrs)
    Set Fnd = Rows(1).Find(what:=tgtHdrs(i), lookat:=xlWhole, MatchCase:=False)
    If Not Fnd Is Nothing Then
        fAdr = Fnd.Address
    End If
    Do
        Range(Fnd.Offset(1, 0), Cells(Rows.Count, Fnd.Column).End(xlUp)).ClearContents
        Set Fnd = Rows(1).FindNext(Fnd)
        If Fnd Is Nothing Then Exit Do
        If Fnd.Address = fAdr Then Exit Do
    Loop
Next i
Application.ScreenUpdating = True
End Sub

 

[lrobbo314]

Another way.

Sub HDELETE()
Application.ScreenUpdating = False
Dim LR As Long: LR = Range("A" & Rows.Count).End(xlUp).Row
Dim r As Range: Set r = Range("A1").CurrentRegion.Resize(1)
Dim s As String: s = "Mary Lee;Bob Smith"
Dim tmp As Range

For Each cel In r
    If InStr(s, cel.Value) > 0 Then
        Set tmp = cel.Offset(1).Resize(LR - 1, 1)
        tmp.ClearContents
    End If
Next cel
Application.ScreenUpdating = True
End Sub

 

[tropics123]

Thank you JoeMo, your macro worked perfectly!!!!! I really appreciate your help!

 

[tropics123]

Thank you Irobbo314 for weighing in. I have yours as backup I really appreciate the second method!!

 

[JoeMo]

Thank you JoeMo, your macro worked perfectly!!!!! I really appreciate your help!

You are welcome - thanks for the reply.