Hi TroyT

New version:

Sub InsertCells()
Dim lngRow As Long
Dim rngHold As Range

Range("A2").Select

Do
If StrComp(ActiveCell.Value, ActiveCell.Offset(0, 1).Value,
vbTextCompare) < 0 Then
Set rngHold = ActiveCell
lngRow = 1
Do While StrComp(ActiveCell.Value,
ActiveCell.Offset(lngRow, 1).Value, vbTextCompare) < 0 And (Not
IsEmpty(ActiveCell.Offset(lngRow, 1)))
lngRow = lngRow + 1
Loop
If IsEmpty(rngHold.Offset(lngRow, 1)) Then
lngRow = 1
Do While StrComp(rngHold.Offset(lngRow, 0).Value,
rngHold.Offset(0, 1).Value, vbTextCompare) < 0 And (Not
IsEmpty(ActiveCell.Offset(lngRow, 1)))
lngRow = lngRow + 1
Loop
If IsEmpty(rngHold.Offset(lngRow, 0)) Then
If IsEmpty(rngHold.Offset(1, 0)) Then
rngHold.Cut Destination:=rngHold.Offset(1, 0)
Else
Range(rngHold, rngHold.Offset(lngRow,
1)).Select
Selection.Cut Destination:=rngHold.Offset(1, 0)
rngHold.Offset(0, 1).Cut
Destination:=rngHold.Offset(-1, 1)
End If
rngHold.Offset(-1, 0).Interior.Color = vbRed
rngHold.Offset(0, 1).Interior.Color = vbGreen
Else
If IsEmpty(rngHold.Offset(1, 1)) Then
Range(rngHold.Offset(0, 1), rngHold.Offset(0,
1)).Select
Else
Range(rngHold.Offset(0, 1), rngHold.Offset(0,
1).End(xlDown)).Select
End If
Selection.Cut Destination:=rngHold.Offset(lngRow,
1)
Range(rngHold.Offset(0, 1), rngHold.Offset(lngRow -
1, 1)).Interior.Color = vbGreen
End If
Else
If IsEmpty(rngHold.Offset(1, 0)) Then
Range(rngHold, rngHold).Select
Else
Range(rngHold, rngHold.End(xlDown)).Select
End If
Selection.Cut Destination:=rngHold.Offset(lngRow, 0)
Range(ActiveCell, ActiveCell.End(xlDown).Offset(-1,
0)).Interior.Color = vbRed
End If
rngHold.Select
End If

ActiveCell.Offset(1, 0).Select
Loop Until IsEmpty(ActiveCell) Or IsEmpty(ActiveCell.Offset(0, 1))
End Sub


Goodluck

Executor