Option Explicit
Sub test()
Dim myAreas As Areas, myArea As Range, dico As Object
Dim a, i As Long, n As Long
    Set dico = CreateObject("Scripting.Dictionary")
    dico.CompareMode = 1
    Application.ScreenUpdating = False
    With Sheets("Feuil1")    'la feuille ACCESSOIRE ds ton exemple
        n = .Range("a" & Rows.Count).End(xlUp).Row
        If n > 1 Then
            With .Range("b6", .Range("b" & Rows.Count).End(xlUp))
                On Error Resume Next
                Set myAreas = .SpecialCells(2).Areas
                On Error GoTo 0
            End With
            If Not myAreas Is Nothing Then
                'On determine les cles du dictionnaire
                'soit le N°Interne si j'ai bien compris
                For Each myArea In myAreas
                    dico(myArea(2).Value) = Empty
                Next
            End If
        End If
        a = Sheets("SYNTHESE").Range("A4").CurrentRegion.Value
        If n = 1 Then n = 6 Else n = n + 2
        For i = 2 To UBound(a, 1)
            If a(i, 1) = "Accessoire" Then
                'si le n°interne n'existe pas ds la feuille synthese
                If Not dico.exists(a(i, 4)) Then
                    'On genere un nouveau petit tableau de 4 x 4
                    ReDim b(1 To 4, 1 To 4)
                    b(1, 1) = a(1, 2): b(1, 2) = a(i, 2): b(1, 3) = "Réglementation :"
                    b(2, 1) = a(1, 4): b(2, 2) = a(i, 4): b(2, 3) = "Périodicité règlementaire (mois) :"
                    b(3, 1) = "CMU :": b(3, 3) = "Lieu :"
                    b(4, 1) = "Caractéristiques :"
                    'Restitution et mise en forme du tableau
                    With .Cells(n, 1).Resize(UBound(b, 1), UBound(b, 2))
                        .Value = b
                        .Borders.Weight = 2
                        .Rows(4).Offset(, 1).Resize(, 3).MergeCells = True
                    End With
                    n = n + 5
                End If
            End If
        Next
        Set dico = Nothing
        With .UsedRange
            .VerticalAlignment = xlCenter
            .Font.Name = "Calibri"
            .Font.Size = 10
            .Columns("a:d").ColumnWidth = Array(17, 12, 30, 20)
        End With
        With .Cells(4, 1)
            .Font.Size = 11
            .Interior.ColorIndex = 42
            .Resize(, 4).MergeCells = True
            .Value = "ACCESSOIRES"
        End With
    End With
    Application.ScreenUpdating = True
End Sub