creer des tableaux dans d'autres feuilles à partir d'un tableau

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