Générer des Feuilles par fournisseur

Sub SplitData() 'EDITION version modifiée pour copier la ligne d'entête
'code initial d'Alex P. ->-> stackoverflow
    Dim DataMarkers(), Names As Range, name As Range, n As Long, i As Long

    Set Names = Range(Cells(2, "D"), Cells(Rows.Count, "D").End(xlUp))
    n = 0
    DeleteWorksheets

    For Each name In Names
        If name.Offset(1, 0) <> name Then
            ReDim Preserve DataMarkers(n)
            DataMarkers(n) = name.Row
            Worksheets.Add(After:=Worksheets(Worksheets.Count)).name = name
            n = n + 1
        End If
    Next name
'
    For i = 0 To UBound(DataMarkers)
        If i = 0 Then
        Worksheets(1).Range("A1:R1").Copy Destination:=Worksheets(i + 2).Range("A1")
        Worksheets(1).Range("A2:R" & DataMarkers(i)).Copy Destination:=Worksheets(i + 2).Range("A2")
        Else
        Worksheets(1).Range("A1:R1").Copy Destination:=Worksheets(i + 2).Range("A1")
        Worksheets(1).Range("A" & (DataMarkers(i - 1) + 1) & ":R" & DataMarkers(i)).Copy Destination:=Worksheets(i + 2).Range("A2")
        End If
    Next i
End Sub

Sub DeleteWorksheets()
    Dim ws As Worksheet, activeShtIndex As Long, i As Long

    activeShtIndex = ActiveSheet.Index

    Application.DisplayAlerts = False
    For i = ThisWorkbook.Worksheets.Count To 1 Step -1
        If i <> activeShtIndex Then
            Worksheets(i).Delete
        End If
    Next i
    Application.DisplayAlerts = True
End Sub