Sub Transposition()
Dim Sht As Worksheet
Dim DLig As Long, Lig As Long, NbLig As Integer, FirstL As Long
Dim Col As Integer, MaxCol As Integer, NumOrg As Integer
Dim sUser As String
' Désactiver certaines fonctions
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.ScreenUpdating = False
' Initialiser les variables
Set Sht = Sheets("AVANT")
DLig = Sht.Range("A" & Rows.Count).End(xlUp).Row
FirstL = 2: Lig = 3
' Pour chaque ligne
Do While Sht.Range("A" & Lig) <> ""
' Récupérer la référence utilisateur
sUser = Sht.Range("A" & FirstL).Value
' Récupérer le numéro de la première ligne de l'utilisateur
NbLig = Application.WorksheetFunction.CountIf(Sht.Range("A:A"), sUser)
' Inscrire les éléments sur la première ligne
Do While Sht.Range("A" & Lig) = sUser
' Prochaine colonne vide
Col = Sht.Cells(FirstL, Columns.Count).End(xlToLeft).Column
NumOrg = Right(Sht.Cells(1, Col), 1)
Col = Col + (3 - NumOrg) + 1
' Vérifier le numéro de la dernière
MaxCol = Sht.Cells(1, Columns.Count).End(xlToLeft).Column
' Si la prochaine colonne vide est > à la dernière
If Col > MaxCol Then
' copier / coller les entêtes puis le format des colonnes
Sht.Range("D1:F1").Copy Destination:=Sht.Cells(1, Col)
Sht.Range("D:F").Copy
Sht.Cells(1, Col).PasteSpecial Paste:=xlPasteFormats
End If
' Copier coller les informations
Sht.Range("D" & Lig & ":F" & Lig).Copy Destination:=Sht.Cells(FirstL, Col)
' Supprimer la ligne
Sht.Rows(Lig).Delete
Loop
' Définir la nouvelle première ligne
FirstL = Lig: Lig = FirstL + 1
Loop
' Ré-activer les fonctions
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub