Sub extraction()
Dim i As Integer, i2 As Integer, f1 As Worksheet, f2 As Worksheet
Set f1 = Sheets("Feuil1")
Set f2 = Sheets("Feuil2")
f2.Range(f2.Cells(2, 2), f2.Cells(1000, 17)).Clear
fin = f1.Range("B" & Rows.Count).End(xlUp).Row
i2 = 2
For i = 2 To fin
If f1.Cells(i, 13) <> "" Then
f1.Range(f1.Cells(i, 2), f1.Cells(i, 11)).Copy f2.Cells(i2, 2)
f2.Cells(i2, 12) = f1.Cells(i, 12)
f2.Cells(i2, 13) = f1.Cells(i, 13)
i2 = i2 + 1
End If
If f1.Cells(i, 15) <> "" Then
f1.Range(f1.Cells(i, 2), f1.Cells(i, 11)).Copy f2.Cells(i2, 2)
f2.Cells(i2, 12) = f1.Cells(i, 14)
f2.Cells(i2, 13) = f1.Cells(i, 15)
i2 = i2 + 1
End If
If f1.Cells(i, 17) <> "" Then
f1.Range(f1.Cells(i, 2), f1.Cells(i, 11)).Copy f2.Cells(i2, 2)
f2.Cells(i2, 12) = f1.Cells(i, 16)
f2.Cells(i2, 13) = f1.Cells(i, 17)
i2 = i2 + 1
End If
Next i
f2.Select
End Sub