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
Bookmarks