Option Explicit
Sub test()
Dim a, w(), x(), e, i As Long, j As Long, n As Long
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
a = Sheets("Feuil1").Range("c3").CurrentRegion.Value
n = 1
For i = 2 To UBound(a, 1)
If Not .exists(a(i, 1)) Then
n = n + 1: ReDim w(1 To 2)
ReDim x(1 To 7, 1 To 2)
w(1) = n
For j = 1 To 6
x(j, 1) = a(1, j)
Next
x(7, 1) = a(1, 8)
Else
w = .Item(a(i, 1))
x = w(2)
ReDim Preserve x(1 To 7, 1 To UBound(x, 2) + 1)
End If
For j = 1 To 6
x(j, UBound(x, 2)) = a(i, j)
Next
x(7, UBound(x, 2)) = a(i, 8)
w(2) = x
.Item(a(i, 1)) = w
Next
For Each e In .keys
If Not IsSheetExists("Feuil" & .Item(e)(1)) Then
Sheets.Add(after:=Sheets(Sheets.Count)).Name = "Feuil" & .Item(e)(1)
End If
w = .Item(e)(2)
With Sheets("Feuil" & .Item(e)(1)).Cells(1)
.CurrentRegion.Clear
With .Resize(UBound(w, 2), UBound(w, 1))
.Value = Application.Transpose(w)
.Font.Name = "calibri"
.Font.Size = 10
.VerticalAlignment = xlCenter
.BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
With .Rows(1)
.BorderAround Weight:=xlThin
.HorizontalAlignment = xlCenter
.Interior.ColorIndex = 40
.Font.Size = 11
End With
'.Columns.AutoFit
.Columns.ColumnWidth = 19
.Rows.RowHeight = 18
End With
End With
Next
End With
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
Function IsSheetExists(ByVal sn As String) As Boolean
On Error Resume Next
IsSheetExists = Len(Sheets(sn).Name)
End Function