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