Macro to delete all rows below Specific Text Starting from the first blank row

[athermian]

Hi,

I have these massive projects to convert 800 excel files with up to 200 worksheets into a DB.

As you can imagine the worksheet is divided into sections and each section is separated by a blank row.

Graham Mayor wrote this macro for me which I want to be modified to:

• Search for a text string
• When the string is found, look for the first empty row and then delete all rows below.

I would be grateful if you can help me modify this macro.



Thanks,

Ather

Sub DeleteBelow()
'Graham Mayor -- Last updated - 01 Nov 2020'
Dim lngFirstRow As Long, lngLastRow As Long
Dim lngCount As Long
Dim fRg As Range
Set fRg = Cells.Find(what:="Header Details", lookat:=xlWhole)
lngFirstRow = fRg.Row + 1
'If lngFirstRow < 11 Then lngFirstRow = 11 'to delete from row 11
lngLastRow = ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row
For lngCount = lngLastRow To lngFirstRow Step -1
Rows(lngCount).EntireRow.Delete
Next lngCount
Set fRg = Nothing
End Sub

 

[JB2020]

I think this should work, assuming I have understood correctly

Sub DeleteBelow()

    Dim KeepRange As Range
    Dim RangeAfterBlankRow As Range
    
    Set KeepRange = Cells.Find(what:="Header Details", lookat:=xlWhole).CurrentRegion
    Set RangeAfterBlankRow = Range(KeepRange.Resize(1, 1).Offset(KeepRange.Rows.count + 1), ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell))
    
    RangeAfterBlankRow.EntireRow.Delete
    
End Sub