Sub Transfert()
Application.ScreenUpdating = False
Dim T, Sortie, Ligne%, i%
[D3:D10000].ClearContents
DL = Range("A65500").End(xlUp).Row
T = Range("A3:A" & DL)
ReDim Sortie(1 To 2 * UBound(T), 1 To 1)
Ligne = 1
For i = 1 To UBound(T)
Sortie(Ligne, 1) = T(i, 1)
Ligne = Ligne + 2
Next i
[D3].Resize(UBound(Sortie, 1), UBound(Sortie, 2)) = Sortie
End Sub