Sub TESTexample()
Dim lastrow As Integer
lastrow = Cells(Rows.Count, 1).End(xlUp).Row
Dim lastcol As Integer
lastcol = Cells(1, Columns.Count).End(xlToLeft).Column
Dim r As Integer
Dim c As Integer
For r = lastrow To 2 Step -1
For c = lastcol To 3 Step -1If Cells(r, c) <> "" Then
Rows(r + 1).Insert
Cells(r + 1, 1) = Cells(r, 1)
Cells(r + 1, 2) = Cells(r, c)
Cells(r, c).Clear
Else: Rows(r).Delete
End If
Next
Next
End Sub