Sub Transpose2()
Dim Plage As Range, F As Worksheet, Cel As Range
Set Plage = Application.InputBox("Sélectionner la plage à transposer", Type:=8)
Application.ScreenUpdating = False
Set F = Sheets.Add(, ActiveSheet)
Plage.Copy F.Range("A1")
F.UsedRange.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:="" & Chr(10) & "", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1)), _
TrailingMinusNumbers:=True
F.Columns("A").Insert Shift:=xlToRight
For Each Cel In F.UsedRange
If Cel <> "" Then F.Range("A35536").End(xlUp).Offset(1) = Cel
Next Cel
F.UsedRange.Offset(, 1).ClearContents
F.Range("A2").CurrentRegion.Copy
Application.ScreenUpdating = True
End Sub