On Nov 12, 12:29*pm, 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

Something simple like this?
Sub insertcolsifnomatch()
Dim i As Long
For i = Cells(2, Columns.Count).End(xlToLeft).Column To 4 Step -2
If Cells(2, i - 1) < Cells(2, i) Then Columns(i).Resize(, 2).Insert
Next i
End Sub