Sub triertableau()
Dim tabresultat()
Dim i As Integer
Dim j As Integer
Dim c As Integer
Dim x As Integer
x = 1
c = 2
For i = 2 To 6 Step 2
c = c + 1
For j = 1 To Cells(65536, i).End(xlUp).Row
ReDim Preserve tabresultat(1 To 6, 1 To x)
tabresultat(1, x) = Cells(j, i)
tabresultat(c, x) = Cells(j, i + 1)
x = x + 1
Next j
Next i
Sheets('feuil1').Range('a1').Resize(UBound(tabresultat, 2), UBound(tabresultat, 1)) = Application.Transpose(tabresultat)
End Sub