Modifiquei a função subject para remover seleções existentes ao reselecioná-las e remover ;'s extras. Segue o código revisado:
Private Sub Worksheet_Change (ByVal Target As Range)
'Atualizado por Extendoffice 2019/11/13
'Atualizado por Ken Gardner 2022/07/11
Dim xRng como intervalo
Dim xValue1 como string
Dim xValue2 como string
Dim semiColonCnt como inteiro
Se Target.Count > 1, então Exit Sub
On Error Resume Next
Definir xRng = Cells.SpecialCells(xlCellTypeAllValidation)
Se xRng não for nada, saia do sub
Application.EnableEvents = False
'Se não for Application.Intersect(Target, xRng) não é nada então
Se Application.Intersect(Target, xRng) Then
xValue2 = Alvo.Valor
Aplicativo.Desfazer
xValue1 = Alvo.Valor
Alvo.Valor = xValue2
Se xValue1 <> "" Então
Se xValue2 <> "" Então
Se xValue1 = xValue2 Ou xValue1 = xValue2 & ";" Ou xValue1 = xValue2 & "; " Então 'deixe o valor se apenas um na lista
xValue1 = Replace(xValue1, "; ", "")
xValue1 = Replace(xValue1, ";", "")
Alvo.Valor = xValue1
ElseIf InStr(1, xValue1, "; " & xValue2) Then
xValue1 = Replace(xValue1, xValue2, "") ' remove o valor existente da lista ao repetir a seleção
Alvo.Valor = xValue1
ElseIf InStr(1, xValue1, xValue2 & ";") Then
xValue1 = Replace(xValue1, xValue2, "")
Alvo.Valor = xValue1
Outro
Target.Value = xValue1 & "; " & xValue2
Se acabar
Target.Value = Replace(Target.Value, ";;", ";")
Target.Value = Replace(Target.Value, "; ;", ";")
If InStr(1, Target.Value, "; ") = 1 Then ' check for ; como primeiro caractere e remova-o
Target.Value = Replace(Target.Value, "; ", "", 1, 1)
Se acabar
If InStr(1, Target.Value, ";") = 1 Then
Target.Value = Replace(Target.Value, ";", "", 1, 1)
Se acabar
semivírgulaCnt = 0
Para i = 1 Para Len(Target.Value)
If InStr(i, Target.Value, ";") Então
semiColonCnt = semiColonCnt + 1
Se acabar
Proximo eu
If semiColonCnt = 1 Then ' remove ; se último caractere
Target.Value = Replace(Target.Value, "; ", "")
Target.Value = Replace(Target.Value, ";", "")
Se acabar
Se acabar
Se acabar
Se acabar
Application.EnableEvents = True
End Sub