Sub Intercaler()
Dim Lg&, i%
Application.ScreenUpdating = False
Lg = Range("A" & Rows.Count).End(xlUp).Row
For i = Lg + 1 To 3 Step -1
If IsEmpty(Cells(i - 1, "D")) And IsEmpty(Cells(i - 1, "G")) Then
i = i - 1
Else
Cells(i, "A").EntireRow.Insert
Rows(i).Resize(1, 2).Value = Rows(i - 1).Resize(1, 2).Value
Cells(i, 3).Value = Cells(i - 1, 4).Value
Cells(i - 1, 4) = Empty
Cells(i, 6).Value = Cells(i - 1, 7).Value
Cells(i - 1, 7) = Empty
Cells(i, 5) = "CN"
End If
Next i
End Sub