AW: Doppelte Werte in Zelle löschen
23.01.2013 09:54:07
Matze
Hallo Phil,
Hab das gefunden und etwas umgebaut , viel Spaß damit. Hoffe es funktioniert wie gewünscht.
Sub DoppelteWeg()
Dim strT As String
Dim strZ As String
Dim sCol As Collection
Dim sColZ As Variant
Dim intA As Integer
Dim intS As Integer
Dim intPos() As Integer
Dim rngZ As Range
On Error Resume Next
For Each rngZ In Selection.Cells
Set sCol = New Collection
strZ = rngZ.Value
intA = Len(strZ) - Len(Application.WorksheetFunction.Substitute(strZ, ",", ""))
ReDim intPos(0 To intA)
For intS = 1 To intA
intPos(intS) = InStr(intPos(intS - 1) + 1, strZ, ",")
Next intS
For intS = 1 To intA
strT = Mid(strZ, intPos(intS - 1) + 1, intPos(intS) - intPos(intS - 1) - 1)
sCol.Add strT, strT
strT = ""
Next intS
strT = Right(strZ, Len(strZ) - intPos(intA))
sCol.Add strT, strT
strZ = ""
For Each sColZ In sCol
strZ = strZ & sColZ & ","
Next sColZ
strZ = Left(strZ, Len(strZ) - 1)
rngZ.Value = strZ
Set sCol = Nothing
Next rngZ
End Sub
Matze