Sub es()
Dim i As Long
Application.ScreenUpdating = False
For i = 16 To Cells(Rows.Count, 1).End(xlUp).Row
If Cells(i, 1) <> "" Then
Cells(i, 2) = Cells(i, 4)
Cells(i, 3) = Cells(i + 1, 1)
Cells(i, 4) = Cells(i + 2, 1)
Cells(i, 6) = Cells(i + 1, 5)
Cells(i, 7) = Cells(i + 2, 5)
Cells(i, 8) = Cells(i, 10)
Cells(i, 10) = ""
End If
Next i
For i = Cells(Rows.Count, 1).End(xlUp).Row To 16 Step -1
If Cells(i, 8) = "" Then Rows(i).Delete
Next i
End Sub