Sub move()
Application.ScreenUpdating = False
Dim i As Long, k As Long, u As Long
i = 2
Do Until i > Cells(65536, "A").End(xlUp).Row
If Cells(i, "A").Value <> "" Then
k = i
u = 4
Do Until u > Cells(k, "IV").End(xlToLeft).Column
If Cells(k, u).Value <> "" Then
Rows(i + 1).Insert
Cells(i + 1, "B").Value = Cells(k, u).Value
Cells(i + 1, "c").Value = Cells(k, u + 1).Value
Cells(i + 1, "A").Value = Cells(k, "A").Value
Cells(k, u).ClearContents
Cells(k, u + 1).ClearContents
i = i + 1
u = u + 2
Else
u = u + 2
End If
Loop
End If
i = i + 1
Loop
MsgBox "Done"
Application.ScreenUpdating = True
End Sub
|