Sub DeleteCellsBelowText()
    Dim rng As Range
    Dim cell As Range
    
    ' Set the range to the entire used range of the active worksheet
    Set rng = ActiveSheet.UsedRange
    
    ' Loop through each cell in the range
    For Each cell In rng
        ' Check if the cell contains text
        If Not IsEmpty(cell.Value) And cell.Value <> "" Then
            ' Delete the cell below
            cell.Offset(1, 0).Delete shift:=xlUp
        End If
    Next cell
End Sub