Microsoft 365 [VBA] Liste déroulante en cascade avec affichage de la 1ère référence trouvée

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Intersect(Target, [B3]) Is Nothing Then Exit Sub
With Sheets("A MASQUER")
    .Columns("A:B").Clear 'RAZ
    Sheets("LISTE").UsedRange.Columns(1).Copy .[A1]
    .Columns(1).Sort .[A1], xlAscending, Header:=xlYes 'tri alphabétique
    .Columns(1).RemoveDuplicates 1, xlYes 'supprime les doublons
    [B3].Validation.Delete 'RAZ
    [B3] = ""
    With .[A1].CurrentRegion
        If .Count > 1 Then
            .Offset(1).Resize(.Count - 1).Name = "VILLES" 'plage nommée
            [B3].Validation.Add xlValidateList, Formula1:="=VILLES"
            CreateObject("WScript.Shell").SendKeys "%{DOWN}" 'déroule la liste
        End If
    End With
End With
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False 'désactive les évènements
With Sheets("A MASQUER")
    .Columns("B:D").Clear 'RAZ
    Sheets("LISTE").UsedRange.AutoFilter 1, [B3]
    Sheets("LISTE").UsedRange.Columns(2).Copy .[C1]
    Sheets("LISTE").UsedRange.AutoFilter
    .Columns(3).RemoveDuplicates 1, xlYes 'au cas où...
    [B6].Validation.Delete 'RAZ
    [B6] = ""
    With .[C1].CurrentRegion
        If .Count > 1 Then
            .Offset(1).Resize(.Count - 1).Name = "PRODUITS" 'plage nommée
            [B6].Validation.Add xlValidateList, Formula1:="=PRODUITS"
            [B6] = [PRODUITS].Cells(1)
        Else
            ThisWorkbook.Names.Add "PRODUITS", "=#N/A"
        End If
    End With
End With
Application.EnableEvents = True 'réactive les évènements
End Sub

Sub Suivant()
Dim c As Range, R As Range, n&
If IsError([PRODUITS]) Then Exit Sub
Application.EnableEvents = False 'désactive les évènements
Set c = [B6]
Set R = [PRODUITS]
If c <> "" Then n = Application.Match(c, R, 0): If n < R.Count Then c = R(n + 1)
If n >= R.Count - 1 Then MsgBox "Vous êtes arrivé en fin de liste"
Application.EnableEvents = True 'réactive les évènements
End Sub

If Target.Address = "$B$6" Then Exit Sub

If c <> "" Then n = Application.Match(c, R, 0): If n < R.Count Then _
    c = R(n + 1) Else MsgBox "Vous êtes arrivé en fin de liste"

If Target.Address = "$B$6" Then Exit Sub