Thread: Deleting duplicated data from 1 cell.

try..

Option Explicit
Sub ptest()
    Dim Unqiue As New Collection, UnqiueVal, a, x
    For Each UnqiueVal In Split(Range("A3"), ",")
        Unqiue.Add UnqiueVal, CStr(UnqiueVal)
        On Error Resume Next
    Next UnqiueVal
    For a = 1 To Unqiue.Count
        Debug.Print Unqiue.Item(a)
        x = Unqiue.Item(a) + "," + x
    Next
    Range("B3") = x
End Sub

this is better it gets ride of the trailing ,

Option Explicit
Sub ptesttwo()
    Dim Unqiue As New Collection, UnqiueVal, a, x
    For Each UnqiueVal In Split(Range("A3"), ",")
        y = Trim(UnqiueVal)
        Unqiue.Add UnqiueVal, CStr(y)
        On Error Resume Next
    Next UnqiueVal
    For a = 1 To Unqiue.Count
         x = x & IIf(x <> "", ",", "") & Unqiue.Item(a)
    Next
    Range("A3").ClearContents
    Range("A3") = x
End Sub

Ben Lewis,

See the attached workbook "Array - Deleting duplicate data from a cell - Ben Lewis - SDGD12.xlsm" with macro "RemoveStringDups".

Detach the workbook and run the "RemoveStringDups" macro.

hi all,

Here's another variant which is similar to Pike's & Stanley's - I tried to post last night but had connection issues.
It works on the current selection (no error checking for selection type though) & uses Join after working through the elements of the array. I have tried to make it work for non-contiguous ranges as well by looping through the selected areas. It is based on some of Jindon's code that I picked up some time ago.
Potentially, it (or the others) could be made faster by creating in memory arrays based on the range, processing the strings, & then writing them back to the sheet in one hit (instead of one cell at a time). This would become more significant as the selection size increases.

Option Explicit
Public glb_origCalculationMode As Long
'an added extra, in case there are formulae which depend on the cells in the processed range.
Sub ToggleRefreshApp(RefreshAppSettings As Boolean)
    With Application
        If Not RefreshAppSettings Then
            glb_origCalculationMode = .Calculation
        End If
        .EnableEvents = RefreshAppSettings
        On Error Resume Next
        .Calculation = IIf(RefreshAppSettings, glb_origCalculationMode, xlCalculationManual)
        '.Calculation = IIf(RefreshAppSettings, xlCalculationAutomatic, xlCalculationManual)
        On Error GoTo 0
        .ScreenUpdating = RefreshAppSettings
        .StatusBar = False    'this should really be stored as a glb variable & restored, but impact is likely to be minimal
    End With
End Sub

Sub RemoveDupsFromWithinCellStr()
Const DelimiterStr As String = ", "
Dim ArryDir As Variant
Dim i As Long
Dim j As Long
Dim nodupes As New Collection
Dim cll As Range
Dim Swap1 As Variant
Dim Swap2 As Variant
Dim nwArr As Variant
Dim trgt As Range
Dim CllArea As Range
    Call ToggleRefreshApp(False)
    Set trgt = Selection
    For Each CllArea In trgt
        For Each cll In CllArea
            ArryDir = Split(cll.Value2, DelimiterStr, -1)        'minus 1 is Optional (added by me)
            For i = LBound(ArryDir) To UBound(ArryDir)
                On Error Resume Next
                If Trim(ArryDir(i)) <> "" Then nodupes.Add Trim(ArryDir(i)), Trim(ArryDir(i))
                '          Note: the 2nd argument (key) for the Add method must be a string
                '      Resume normal error handling
                On Error GoTo 0
            Next i
            '            '   Sort the collection (optional)
            '            For i = 1 To nodupes.Count - 1
            '                For j = i + 1 To nodupes.Count
            '                    If nodupes(i) > nodupes(j) Then
            '                        Swap1 = nodupes(i)
            '                        Swap2 = nodupes(j)
            '                        nodupes.Add Swap1, Before:=j
            '                        nodupes.Add Swap2, Before:=i
            '                        nodupes.Remove i + 1
            '                        nodupes.Remove j + 1
            '                    End If
            '                Next j
            '            Next i
            '   Delete existing items in list, add the sorted (?), non-duplicated items back to the cell
            ReDim nwArr(0 To nodupes.Count - 1)
            For i = 0 To nodupes.Count - 1
                nwArr(i) = nodupes.Item(i + 1)
            Next i
            'for testing...            If Not IsEmpty(nwArr) Then cll.Offset(0, 1).Value2 = Join(nwArr, DelimiterStr)
            If Not IsEmpty(nwArr) Then cll.Value2 = Join(nwArr, DelimiterStr)
        Next cll
    Next CllArea
    Call ToggleRefreshApp(True)
End Sub

hth
Rob

hi Ben Lewis
or with the more adaptable dictionary

Option Explicit
Sub ptesttwo()
    Dim y$, x, z
    With CreateObject("Scripting.Dictionary")
        .CompareMode = vbTextCompare
        For Each z In Split(Range("A3"), ",")
            y = Trim(z)
            If Not .exists(y) Then
                .Add y, y
                x = x & IIf(x <> "", ",", "") & y
            End If
        Next
        Range("A3").ClearContents
        Range("A3") = x
    End With
End Sub