Macro to insert row and text above cell

[MD011]

Good afternoon everyone,


I currently have the below code which deletes all the text out of that column except for the text in the cell i have selected when i run the macro:


Sub Clear_data_From_Selected_Column()


Dim lastRow, uCol, uRow As Long


lastRow = Cells.Find("", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row


uCol = ActiveCell.Column
uRow = ActiveCell.Row


Range(Cells(uRow + 1, uCol), Cells(lastRow, uCol)).Select


Selection.ClearContents


End Sub






I need to make a couple of additions to this macro so that it does the following:


I need the macro to insert a blank row above the current cell, and insert the text "Removed" (in red font if possible?) into the cell above the current cell in the newly created row.


However if there already is a blank row above, i need the macro to simply just insert the "Removed" text rather than adding another blank row.


I hope that makes sense and thank you for the help in advance.


Thanks.

[p45cal]

code which deletes all the text out of that column except for the text in the cell i have selected when i run the macroAlmost; it deletes the data from the cells of that column only below the active cell.
Try:

Sub Clear_data_From_Selected_Column()
Range("H5").Select
Set CurrentCell = ActiveCell
If Application.CountA(Rows(CurrentCell.Row - 1).EntireRow) > 0 Then Rows(CurrentCell.Row).Insert
With CurrentCell.Offset(-1)
.Value = "Removed"
.Font.ColorIndex = 3
End With
Dim lastRow, uCol, uRow As Long
lastRow = Cells.Find("", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
uCol = CurrentCell.Column
uRow = CurrentCell.Row
Range(Cells(uRow + 1, uCol), Cells(lastRow, uCol)).Select
Selection.ClearContents
End Sub