I find it much easier to work with the column numbers and looping from the
rightmost toward the left in cases like this (and starting at the bottom and
working toward the top when working with rows).

Option Explicit
Sub testme()

Dim iCol As Long
Dim FirstCol As Long
Dim LastCol As Long
Dim wks As Worksheet

Set wks = Worksheets("sheet1") 'ActiveSheet ???

With wks
FirstCol = .Range("D2").Column '4
LastCol = .Range("D2").End(xlToRight).Column

For iCol = LastCol To FirstCol + 1 Step -1
If .Cells(2, iCol).Value < .Cells(2, iCol - 1).Value Then
.Cells(2, iCol).Resize(, 2).EntireColumn.Insert
End If
Next iCol
End With

End Sub



On 11/12/2010 12:29, Frank wrote:
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

--
Dave Peterson