Ik heb de onderwerpfunctie aangepast om bestaande selecties te verwijderen bij het opnieuw selecteren en om extra ;'s te verwijderen. Hier is de herziene code:

Particulier subwerkblad_Wijziging (ByVal-doel als bereik)
'Bijgewerkt door' Extendoffice 2019/11/13
'Bijgewerkt door Ken Gardner 2022/07/11
Dim xRng als bereik
Dim xValue1 als tekenreeks
Dim xValue2 als tekenreeks
Dim puntkommaCnt As Integer
Als Target.Count > 1 Sub afsluiten
On Error Resume Next
Stel xRng = Cells.SpecialCells (xlCellTypeAllValidation) in
Als xRng niets is, sluit dan Sub af
Application.EnableEvents = False
'If Not Application.Intersect (Target, xRng) is niets dan'
Als Application.Intersect (Target, xRng) Dan
xWaarde2 = Doel.Waarde
Toepassing.Ongedaan maken
xWaarde1 = Doel.Waarde
Doelwaarde = xWaarde2
Als xWaarde1 <> "" Dan
Als xWaarde2 <> "" Dan
Als xWaarde1 = xWaarde2 Of xWaarde1 = xWaarde2 & ";" Of xWaarde1 = xWaarde2 & "; " Dan ' laat de waarde als er maar één in de lijst staat
xWaarde1 = Vervangen(xWaarde1, ";", "")
xWaarde1 = Vervangen(xWaarde1, ";", "")
Doelwaarde = xWaarde1
ElseIf InStr(1, xValue1, "; " & xValue2) Dan
xValue1 = Replace(xValue1, xValue2, "") ' verwijdert bestaande waarde uit de lijst bij herhaalde selectie
Doelwaarde = xWaarde1
ElseIf InStr(1, xWaarde1, xWaarde2 & ";") Dan
xWaarde1 = Vervangen(xWaarde1, xWaarde2, "")
Doelwaarde = xWaarde1
Anders
Doelwaarde = xWaarde1 & "; " & xWaarde2
End If
Doelwaarde = Vervangen(doelwaarde, ";;", ";")
Doelwaarde = Vervangen(doelwaarde, "; ;", ";")
If InStr(1, Target.Value, "; ") = 1 Dan ' controleren op ; als eerste teken en verwijder het
Target.Value = Replace(Target.Value, ";", "", 1, 1)
End If
Als InStr(1, Doelwaarde, ";") = 1 Dan
Target.Value = Replace(Target.Value, ";", "", 1, 1)
End If
puntkommaCnt = 0
Voor i = 1 tot Len (doelwaarde)
Als InStr(i, Target.Value, ";") Dan
puntkommaCnt = puntkommaCnt + 1
End If
Volgende i
Als semiColonCnt = 1 Dan ' verwijderen; als laatste teken
Doelwaarde = Vervangen(doelwaarde, ";", "")
Target.Value = Vervang(Target.Value, ";", "")
End If
End If
End If
End If
Application.EnableEvents = Waar
End Sub