VBA-funktion Worksheet_Change för excel

Jag modifierade ämnesfunktionen för att ta bort befintliga val när jag valde dem igen och för att ta bort extra ;'s. Här är den reviderade koden:

Privata delarkivsförändring (ByVal-mål som område)
'Uppdaterad av Extendoffice 2019/11/13
'Uppdaterad av Ken Gardner 2022/07/11
Dim xRng As Range
Dim xValue1 As String
Dim xValue2 As String
Dim semiColonCnt Som heltal
Om Target.Count > 1 Avsluta Sub
On Error Resume Next
Set xRng = Cells.SpecialCells(xlCellTypeAllValidation)
Om xRng är ingenting, avsluta Sub
Application.EnableEvents = False
'Om inte Application.Intersect(Target, xRng) är ingenting då
Om Application.Intersect(Target, xRng) Då
xValue2 = Target.Value
Application.Ångra
xValue1 = Target.Value
Target.Value = xValue2
Om xValue1 <> "" Då
Om xValue2 <> "" Då
Om xValue1 = xValue2 Eller xValue1 = xValue2 & ";" Eller xValue1 = xValue2 & "; " Sedan ' lämna värdet om bara ett i listan
xValue1 = Ersätt(xValue1, "; ", "")
xValue1 = Ersätt(xValue1, ";", "")
Target.Value = xValue1
ElseIf InStr(1, xValue1, "; " & xValue2) Då
xValue1 = Replace(xValue1, xValue2, "") ' tar bort befintligt värde från listan vid upprepat val
Target.Value = xValue1
ElseIf InStr(1, xValue1, xValue2 & ";") Sedan
xValue1 = Ersätt(xValue1, xValue2, "")
Target.Value = xValue1
annars
Target.Value = xValue1 & "; " & xValue2
End If
Target.Value = Ersätt(Target.Value, ";;", ";")
Target.Value = Replace(Target.Value, "; ;", ";")
Om InStr(1, Target.Value, "; ") = 1 Då ' kontrollera efter ; som första tecken och ta bort det
Target.Value = Replace(Target.Value, "; ", "", 1, 1)
End If
Om InStr(1, Target.Value, ";") = 1 Då
Target.Value = Ersätt(Target.Value, ";", "", 1, 1)
End If
semiColonCnt = 0
För i = 1 Till Len(Target.Value)
Om InStr(i, Target.Value, ";") Då
semiColonCnt = semiColonCnt + 1
End If
Nästa jag
Om semiColonCnt = 1 Då ' remove; om sista tecknet
Target.Value = Replace(Target.Value, "; ", "")
Target.Value = Replace(Target.Value, ";", "")
End If
End If
End If
End If
Application.EnableEvents = True
End Sub