Microsoft 365 Nommer des feuilles en fonction des données d'une colonne

Sub MAJ()
Dim F As Worksheet, w As Worksheet, d As Object, P As Range, c As Range, x$
Set F = Sheets("Sources")
'---supprime les feuilles---
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each w In Worksheets
    If w.Name <> F.Name Then w.Delete
Next w
'---crée les feuilles---
Set d = CreateObject("Scripting.Dictionary")
Set P = F.[A1].CurrentRegion
For Each c In P.Offset(1).Columns(7).Cells
    x = UCase(c)
    If x <> "" And Not d.exists(x) Then
        d(x) = ""
        Sheets.Add After:=Sheets(Sheets.Count)
        ActiveSheet.Name = x
        P.AutoFilter 7, x 'filtre automatique
        Intersect(P, F.Columns("D:R")).SpecialCells(xlCellTypeVisible).Copy [D1] 'copier-coller
        P.AutoFilter 'ôte le filtre
        Columns.AutoFit 'ajustement largeurs
    End If
Next c
F.Activate
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range, d As Object, x$
Set r = Range("A1", UsedRange).Columns(6).Resize(, 2)
Set Target = Intersect(Target.EntireRow, r)
If Target Is Nothing Then Exit Sub
'---liste sans doublon---
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For Each r In r.Rows
    If r.Row > 1 And r.Cells(1) <> "" And r.Cells(2) <> "" Then
        x = r.Cells(1) & Chr(1) & r.Cells(2) 'concaténation avec séparateur
        d(x) = d(x) + 1 'comptage
    End If
Next r
'---repérage des doublons---
For Each Target In Target.Rows
    If d(Target.Cells(1) & Chr(1) & Target.Cells(2)) > 1 Then
        Application.EnableEvents = False 'désactive les évènements
        Application.Goto Target.Cells(1)
        MsgBox "Doublon en " & Target.Cells(1).Address(0, 0) & " !", 48
        Target.Cells(1) = ""
        Application.EnableEvents = True 'réactive les évènements
        Exit For
    End If
Next Target
End Sub