If the contents of D2 to the end of the row are constants (that is, they NOT
the result of formulas), then you could consider using this non-looping
code...

With Range("D2", Cells(2, Columns.Count).End(xlToLeft))
.Replace .Cells(1), "=" & .Cells(1), xlWhole
.SpecialCells(xlCellTypeConstants).Offset(0, 1).Insert xlShiftToRight
.SpecialCells(xlCellTypeConstants).Offset(0, 1).Insert xlShiftToRight
.SpecialCells(xlCellTypeFormulas).Replace "=", "", xlPart
End With

--
Rick Rothstein (MVP - Excel)



"Frank" wrote in message
...
I've created this routing which works but I was hoping for something a
little more clean

Range("D2").Select
Do Until ActiveCell.Offset(0, 1) = ""
If ActiveCell.Offset(0, 1) < ActiveCell Then
Range(ActiveCell.Offset(0, 1), ActiveCell.Offset(0,
2)).EntireColumn.Insert shift:=xlToRight
ActiveCell.Offset(0, 3).Select
Else
ActiveCell.Offset(0, 1).Select
End If
Loop

I had tried the following but it's not working

For Each cell In Range(("D2"), Range("D2").End(xlToRight))
If cell.Offset(0, 1) < cell And cell.Offset(0, 1) < "" Then
Range(cell.Offset(0, 1), cell.Offset(0,
2)).EntireColumn.Insert 'shift:=xlToRight
cell.Offset(0, 3).Select
Else
End If
Next