Bonjour, Salut Dhany !
Une autre méthode... A tester.
Sub RépartOnglets()
Dim Tbl(), TblT(), PlNum, PlTft, nn%, m%, n%, k%, i%
With ActiveSheet.Range("A1").CurrentRegion
n = .Rows.Count
k = .Columns.Count - 1
.Sort key1:=.Cells(1, 1), order1:=xlAscending, Header:=xlYes
PlNum = .Resize(, 1).Value
PlTft = .Offset(, 1).Resize(, k).Value
End With
For i = 2 To UBound(PlNum)
ReDim Preserve Tbl(1, nn)
Tbl(0, nn) = PlNum(i, 1)
ReDim TblT(m)
TblT(m) = WorksheetFunction.Index(PlTft, 1, 0)
Do While PlNum(i, 1) = Tbl(0, nn)
m = m + 1: ReDim Preserve TblT(m)
TblT(m) = WorksheetFunction.Index(PlTft, i, 0)
i = i + 1
If i > UBound(PlNum) Then Exit Do
Loop
Tbl(1, nn) = TblT
nn = nn + 1
Erase TblT
i = i - 1: m = 0
Next i
Application.ScreenUpdating = False
For i = 0 To nn - 1
With Worksheets.Add(after:=Worksheets(Worksheets.Count))
.Name = Tbl(0, i)
.Range("A1").Resize(UBound(Tbl(1, i)) + 1, k).Value = WorksheetFunction.Transpose( _
WorksheetFunction.Transpose(Tbl(1, i)))
End With
Next i
End Sub
Cordialement.