Microsoft 365 VBA création d'onglets à partir d'un tableau et d'un onglet modèle ...

Sub CreerFeuilles()
Dim Cel As Range
Application.ScreenUpdating = False
On Error Resume Next 'si une feuille n'existe pas
With Sheets("Base")
    For Each Cel In .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
        If IsError(Sheets(Cel.Text)) Then
            Sheets("Modèle").Copy After:=Sheets(Sheets.Count)
            ActiveSheet.Name = Cel.Text
        End If
        Sheets(Cel.Text).Cells(1) = Cel.Text
        Sheets(Cel.Text).Cells(4, 1).Resize(4) = Application.Transpose(Cel(1, 2).Resize(, 4))
    Next Cel
    .Activate
End With
Application.ScreenUpdating = True
MsgBox "Traitement terminé"
End Sub

Sub CreerFeuilles()
Dim Cel As Range, x$
Application.ScreenUpdating = False
On Error Resume Next 'si une feuille n'existe pas
With Sheets("Base")
    With .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
        If .Row = 1 Then Exit Sub 'si le tableau est vide
        For Each Cel In .Cells
            x = Cel.Text
            If x <> "" Then
                If IsError(Sheets(x)) Then
                    Sheets("Modèle").Copy After:=Sheets(Sheets.Count)
                    ActiveSheet.Name = x
                End If
                Sheets(x).Cells(1) = x
                Sheets(x).Cells(4, 1).Resize(4) = Application.Transpose(Cel(1, 2).Resize(, 4))
            End If
        Next Cel
    End With
    .Activate
End With
Application.ScreenUpdating = True
MsgBox "Traitement terminé"
End Sub

.Range(Cells(Cel.Row, 2), Cells(Cel.Row, 5)).Copy
Sheets(Cel.Value).Range("A4").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True

Option Explicit
Sub CreerFeuilles()
Dim Cel As Range
Dim Dico
    Set Dico = CreateObject("Scripting.dictionary")
    Application.ScreenUpdating = False
    With Sheets("Base")
        For Each Cel In .Range("A2:A" & .Range("A" & Rows.Count).End(xlUp).Row)
            If Not Dico.Exists(Cel.Value) Then
                Dico.Add Cel.Value, Cel.Value
                If Not FeuilleExiste(Cel.Value) Then
                    Sheets("Modèle").Copy After:=Sheets(Sheets.Count)
                    ActiveSheet.Name = Cel.Value
                End If
            End If
        .Range(Cells(Cel.Row, 2), Cells(Cel.Row, 5)).Copy
        Sheets(Cel.Value).Range("A4").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
        Next Cel
        .Activate
    End With
    Application.ScreenUpdating = True
    MsgBox "Traitement terminé"
End Sub
Public Function FeuilleExiste(NomFeuille As String) As Boolean
Dim Ws As Worksheet
   FeuilleExiste = False
   For Each Ws In ActiveWorkbook.Worksheets
      If Ws.Name = NomFeuille Then
         FeuilleExiste = True
      End If
   Next
End Function