Supprimer un élément d'une liste déroulante après l'avoir choisi

Private Sub Worksheet_Change(ByVal Target As Range)
Dim cel1 As Range, cel2 As Range, P1 As Range, P2 As Range, i As Variant, r As Range, f$
Set cel1 = [G4]: Set cel2 = [H4] 'cellules à adapter
Set P1 = [List_of_prises_reseaux]: Set P2 = [List_of_pieces_batiments] 'plages à adapter
If Not Intersect(Target, cel1) Is Nothing Then
    i = Application.Match(cel1, P2, 0)
    If IsNumeric(i) Then
        Set r = P1(i).Resize(Application.CountIf(P2, cel1))
        For Each r In r: f = f & "," & r: Next 'concaténation
    End If
    With cel2.Validation
        .Delete
        If f <> "" Then .Add xlValidateList, Formula1:=f
    End With
ElseIf Not Intersect(Target, cel2) Is Nothing Then
    On Error Resume Next 'si la formule de validation n'existe pas
    With cel2.Validation
        f = .Formula1
        .Delete
        .Add xlValidateList, Formula1:=Replace(Replace(f, cel2, ""), ";", ",")
    End With
End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim cel As Range, r As Range, d As Object, f$
Set cel = [G4] 'cellule à adapter
Set r = [List_of_pieces_batiments] 'plage à adapter
If Not Intersect(Target, cel) Is Nothing Then
    With cel.Validation
        .Delete
        Set d = CreateObject("Scripting.Dictionary")
        For Each r In r
            If r <> "" Then If Not d.exists(r.Value) Then _
                d(r.Value) = "": f = f & "," & r 'concaténation
        Next
        If d.Count Then .Add xlValidateList, Formula1:=f 'création de la liste en G4
        cel = cel 'création de la liste en H4
    End With
End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim cel1 As Range, cel2 As Range, P1 As Range, P2 As Range, i As Variant, r As Range, f$
Set cel1 = [G4]: Set cel2 = [H4] 'cellules à adapter
Set P1 = [List_of_prises_reseaux]: Set P2 = [List_of_pieces_batiments] 'plages à adapter
If Not Intersect(Target, Union(P1, P2)) Is Nothing Then 'création des listes en G4 et H4
    Worksheet_SelectionChange cel1
    If Not Intersect(Target, P2) Is Nothing Then cel1 = ""
ElseIf Not Intersect(Target, cel1) Is Nothing Then 'création de la liste en H4
    i = Application.Match(cel1, P2, 0)
    If IsNumeric(i) Then
        Set r = P1(i).Resize(Application.CountIf(P2, cel1))
        For Each r In r: f = f & ",," & r: Next 'concaténation avec double séparateur
        f = f & ","
    End If
    With cel2.Validation
        .Delete
        If f <> "" Then .Add xlValidateList, Formula1:=f
    End With
    cel2 = "" 'RAZ
ElseIf Not Intersect(Target, cel2) Is Nothing And CStr(cel2) <> "" Then 'réduction de la liste en H4
    On Error Resume Next 'si Formula1 n'existe pas
    With cel2.Validation
        f = .Formula1
        .Delete
        .Add xlValidateList, Formula1:=Replace(Replace(f, ";", ","), "," & CStr(cel2) & ",", "")
    End With
End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim P As Range, r As Range, d As Object, f$
Set P = [G4:H10] 'plage à adapter
Set r = [List_of_pieces_batiments] 'plage à adapter
If Not Intersect(Target, P.Columns(1)) Is Nothing Then
    For Each Target In Intersect(Target, P.Columns(1)).Areas 'si sélections multiples
        With Target.Validation
            .Delete
            If d Is Nothing Then
                Set d = CreateObject("Scripting.Dictionary")
                For Each r In r
                    If r <> "" Then If Not d.exists(r.Value) Then _
                        d(r.Value) = "": f = f & "," & r 'concaténation
                Next r
            End If
            If d.Count Then .Add xlValidateList, Formula1:=f 'création des listes en colonne G
            Target = Target.Value 'création des listes en colonne H
        End With
    Next Target
End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim P As Range, P1 As Range, P2 As Range, c As Range, f$, i As Variant, r As Range
Set P = [G4:H10] 'plage à adapter
Set P1 = [List_of_prises_reseaux]: Set P2 = [List_of_pieces_batiments] 'plages à adapter
If Not Intersect(Target, Union(P1, P2)) Is Nothing Then 'création des listes en colonnes G et H
    Worksheet_SelectionChange P
    If Not Intersect(Target, P2) Is Nothing Then P.Columns(1) = ""
End If
If Not Intersect(Target, P.Columns(1)) Is Nothing Then 'création des listes en colonne H
    For Each c In Intersect(Target, P.Columns(1)) 'si entrées multiples
        f = ""
        i = Application.Match(c, P2, 0)
        If IsNumeric(i) Then
            Set r = P1(i).Resize(Application.CountIf(P2, c))
            For Each r In r: f = f & ",," & r: Next r 'concaténation avec double séparateur
            f = f & ","
        End If
        With c(1, 2).Validation
            .Delete
            If f <> "" Then .Add xlValidateList, Formula1:=f
        End With
        c(1, 2) = "" 'RAZ
    Next c
End If
If Not Intersect(Target, P.Columns(2)) Is Nothing Then 'réduction des listes en colonne H
    On Error Resume Next 'si Formula1 n'existe pas
    For Each c In Intersect(Target, P.Columns(2)) 'si entrées multiples
        If CStr(c) <> "" Then
            With c.Validation
                f = ""
                f = .Formula1
                .Delete
                .Add xlValidateList, Formula1:=Replace(Replace(f, ";", ","), "," & CStr(c) & ",", "")
            End With
        End If
    Next c
End If
End Sub