Copier transposer dans nouvelle feuilles

Bonjour

J'ai cette macro pour copier et coller dans une nouvelle feuille.

Sub copie()
col = 2
ligne = Range("B" & Rows.Count).End(xlUp).Row
'numero de la colonne de test et calcul du nb de ligne
Dim d, f As Integer 'debut et fin de zone de copie
Data = ActiveSheet.Name
d = 2 'initialisation de la plage a copier
For i = 2 To ligne
   ' MsgBox d
    If Not (Sheets(Data).Cells(i, col) = Sheets(Data).Cells(i + 1, col)) Then
        'MsgBox Cells(i, col) & Cells(i + 1, col)
        nom = Sheets(Data).Cells(i, col)
        Sheets.Add 'ajout de feuille
        ActiveSheet.Name = nom
        f = i 'valeur différente donc fin de la plage a copier
        Sheets(Data).Rows("1:1").Copy 'copie des en-têtes
        Sheets(nom).Rows("1:1").PasteSpecial 'changer sheets par le nomveau nom
        'MsgBox "zone = " & d & " - " & f
        Sheets(Data).Rows(d & ":" & f).Copy 'copie des données
        Sheets(nom).Rows("2:" & 2 + f - d).PasteSpecial 'changer sheets par le nomveau nom
        d = i + 1 'début de la plage suivante
    End If
Next i
End Sub

Mais au lieu de coller je voudrait transposer mais je ne trouve pas

pouvez vous m'aider?

Merci

Bonjour,

ceci ?

Sheets(nom).Rows("1:1").PasteSpecial Transpose:=True

Sheets(nom).Rows("2:" & 2 + f - d).PasteSpecial Transpose:=True

Bonjour Thrrybo

Merci mais cela ne fonctionne pas
avec le fichier test ça peux aider

Merci

Bonsoir,
Une petite contribution.
Cdlt.

Public Sub CopyAndTransposeData()
Dim wb As Workbook
Dim wsData As Worksheet, newWs As Worksheet
Dim rngData As Range

    Set wb = ActiveWorkbook
    Set wsData = wb.Worksheets("Feuil1")
    Set rngData = wsData.Cells(1).CurrentRegion
    Set newWs = wb.Worksheets.Add(after:=wb.Worksheets(wb.Worksheets.Count))

    rngData.Copy

    With newWs
        .Name = "Feuil2"
        With .Cells(1)
            .PasteSpecial Paste:=xlPasteAll, Transpose:=True
            .Resize(1, 2).EntireColumn.AutoFit
        End With
    End With

    Application.CutCopyMode = 0

End Sub