VBA to cut some text and insert above text in another cell

I am trying to build a vba macro that will do a few things.
1. Cut the text from the row I am working on in column A before the word "ACTION:"
2. Insert the text cut from that row into Column B. Now, the same row in column B will probably already have text in it I want to keep. So the macro needs to insert a line to push the old text down a line and then insert the cut text.
3. Make the older text's font in that row smaller, like size 5.
4. Back in column A insert today's date and leave the cursor there to begin typing notes for today.

I also need the text starting at the word "ACTION:" to remain bold.

See that attachment for an example of before and after the macro. Also, the macro only needs to do its magic on the active cell.

Help will be greatly appreciated.

--Jim

Actually, I think I have finally put it all together... Whew!

Sub NewNotes()

'This macro readies my note cell for entering notes by copying the old notes to the cell that keeps the old notes.

Dim Numchars As Long, s As String
Numchars = InStr(1, ActiveCell, "ACTION:", vbTextCompare)
If Numchars <> 0 Then
 cText = Left(ActiveCell, Numchars - 1)
 With ActiveCell.Offset(0, 3)
 .Value = cText & Chr(13) & .Value
 End With
End If

    
 Dim rng2 As Range
 Dim rng As Range
    Dim Length As Integer
    Dim LeftSide As Integer
    Dim RightSide As Integer
    Dim StartingLength As Integer

Set rng = ActiveCell
Set rng2 = ActiveCell.Offset(0, 3)
    StartingLength = Len(rng)
    LeftSide = InStr(rng, "ACTION:")
    RightSide = (InStr(LeftSide, rng, "ACTION:")) - 1
    Length = RightSide - LeftSide
  rng2.Characters(Start:=LeftSide, Length:=65535).Font.Size = 3

Dim R As Range, c As Range, lRw As Long

Set R = Selection
For Each c In R
    c.Value = Format(Date, "mm/d") & ": " & Mid(c.Value, InStr(1, c.Value, Chr(10)))
    c.Characters(InStr(1, c.Value, Chr(10))).Font.Bold = True
    Next c
  
  
End Sub