Duplicates within a cell

[John]

Hi

I would be grateful to anyone who could tell me how to remove
duplicates within a cell. For example, after concatenating a range of
cells I am left with a,b,c,d,a,b,d,c. I would like this to be a,b,c,d,
ie deduplicated and in alphabetical order.

Thanks

John

 

[Frank Kabel]

Hi
this would require IMHO VBA (creating a user defined function)

 

[Harlan Grove]

I would be grateful to anyone who could tell me how to remove
duplicates within a cell. For example, after concatenating a range of
cells I am left with a,b,c,d,a,b,d,c. I would like this to be a,b,c,d,
ie deduplicated and in alphabetical order.

What does the concatenation formula look like? It's a near certainty it'd be
easier to eliminate duplicates BEFORE concatenation than after.

Could this be done after concatenation? Maybe, but it'd involve breaking the
string appart, presumably at each comma, then removing the duplicates, then
reconcatenating.

 

[Myrna Larson]

Here's some VBA code that will do what you want. It assumes the input string
is a comma-delimited list, as you showed in your message. It returns a string
with duplicates removed, and the remaining entries in alphabetical order.

Please post back as to whether this solves your problem.



Option Explicit

Function RemoveDuplicatesAndSort(sText As String) As String
Dim a() As String
Dim b() As String
Dim i As Long
Dim j As Long

a = Split(sText, ",")
ReDim b(0 To UBound(a))
b(0) = a(0)

'transfer unique entries from a() to b()
j = 0
For i = 1 To UBound(a)
If IsError(Application.Match(a(i), b(), 0)) Then
j = j + 1
b(j) = a(i)
End If
Next i

ReDim Preserve b(0 To j)

SortStrings b()

RemoveDuplicatesAndSort = Join(b, ",")

End Function

Sub SortStrings(sArray() As String)
Dim i As Long
Dim j As Long
Dim Lo As Long
Dim Hi As Long
Dim sTemp As String

Lo = LBound(sArray())
Hi = UBound(sArray())

For i = Lo + 1 To Hi
sTemp = sArray(i)
For j = i - 1 To Lo Step -1
If sArray(j) > sTemp Then
sArray(j + 1) = sArray(j)
Else
Exit For
End If
Next j
sArray(j + 1) = sTemp
Next i

End Sub 'SortStrings

 

[Myrna Larson]

it'd involve breaking the

string appart, presumably at each comma, then removing the duplicates, then
reconcatenating.

Hi, Harlan:

You forgot the sorting step <g>.

I've posted some VBA code to do this, assuming his data is comma-delimited as
he showed.

Myrna Larson

 

[Aladin Akyurek]

If you installed the morefunc.xll add-in, the following would give you what
you want:

=SUBSTITUTE(TRIM(MCONCAT(UNIQUEVALUES(A1:G1,1)," "))," ",",")

where A1:G1 is the range you concatenate.

 

[Harlan Grove]

If you installed the morefunc.xll add-in, the following would give you what
you want:

=SUBSTITUTE(TRIM(MCONCAT(UNIQUEVALUES(A1:G1,1)," "))," ",",")

where A1:G1 is the range you concatenate.

....

But if you took the OP at his word and the comma-separated fields were
already in a single cell, say x99, you'd need to replace the A1:G1 above
with

EVAL("{"""&SUBSTITUTE(X99,",",""",""")&"""}")

 

[Aladin Akyurek]

I must be misreading OP's "after concatenating a range of cells I am left
with a,b,c,d,a,b,d,c."

 

[John]

Hi Myrna

Thanks for your help. You are correct in assuming that the values in
the cell(s) are comma delimited and that the duplicates already exist
- ie they reach me after the concatenation has been done elsewhere.

I tried your script as a macro NoDupes but got a compilation error. As
I am not very experienced in this I expect I pasted something in to
the box that shouldn't be there. Can you take a look?

The full content of the module reads:

Sub NoDupes()
Option Explicit

Function RemoveDuplicatesAndSort(sText As String) As String
Dim a() As String
Dim b() As String
Dim i As Long
Dim j As Long

a = Split(sText, ",")
ReDim b(0 To UBound(a))
b(0) = a(0)

'transfer unique entries from a() to b()
j = 0
For i = 1 To UBound(a)
If IsError(Application.Match(a(i), b(), 0)) Then
j = j + 1
b(j) = a(i)
End If
Next i

ReDim Preserve b(0 To j)

SortStrings b()

RemoveDuplicatesAndSort = Join(b, ",")

End Function

Sub SortStrings(sArray() As String)
Dim i As Long
Dim j As Long
Dim Lo As Long
Dim Hi As Long
Dim sTemp As String

Lo = LBound(sArray())
Hi = UBound(sArray())

For i = Lo + 1 To Hi
sTemp = sArray(i)
For j = i - 1 To Lo Step -1
If sArray(j) > sTemp Then
sArray(j + 1) = sArray(j)
Else
Exit For
End If
Next j
sArray(j + 1) = sTemp
Next i

End Sub 'SortStrings

End Sub

Many thanks
John

 

[Myrna Larson]

Hi, John:

Sorry to be so tardy in getting back to you. I guess I missed your message
on Monday.

You have a couple of problems here.

1. The line

Option Explicit

must occur at the very top of the module, outside of any Sub/End Sub or
Function/End Function block.

2. You can't nest one procedure inside another. Remove the lines

Sub NoDupes()

at the very top and

End Sub

at the very bottom.

3. If you want to change the name of the function that I wrote, you can
change BOTH occurrences of RemoveDuplicatesAndSort to something else, i.e.
maybe what you want is the modification I've made below.

To use the *function* NoDupes in a formula in a worksheet cell, the syntax
is =NoDupes(A1), where A1 is the cell containing the original text.

If you want a Sub procedure that will change the data in-place, you could do
it by selecting the cells in question, then running the new sub,
RemoveDupes, that I added.

BTW, this code requires Excel 2000 or later (the Split and Join functions
were added then). It won't run in XL97.


Option Explicit

Function NoDupes(sText As String) As String
Dim a() As String
Dim b() As String
Dim i As Long
Dim j As Long

a = Split(sText, ",")
ReDim b(0 To UBound(a))
b(0) = a(0)

'transfer unique entries from a() to b()
j = 0
For i = 1 To UBound(a)
If IsError(Application.Match(a(i), b(), 0)) Then
j = j + 1
b(j) = a(i)
End If
Next i

ReDim Preserve b(0 To j)

SortStrings b()

NoDupes = Join(b, ",")

End Function


Sub RemoveDupes()
Dim SaveCalc As Long
Dim Cell As Range


With Application
.ScreenUpdating = False
SaveCalc = .Calculation
.Calculation = xlCalculationManual
End With

For Each Cell In Selection
Cell.Value = NoDupes(Cell.Value)
Next Cell

With Application
.ScreenUpdating = True
.Calculation = SaveCalc
End With

End Sub

Sub SortStrings(sArray() As String)
Dim i As Long
Dim j As Long
Dim Lo As Long
Dim Hi As Long
Dim sTemp As String

Lo = LBound(sArray())
Hi = UBound(sArray())

For i = Lo + 1 To Hi
sTemp = sArray(i)
For j = i - 1 To Lo Step -1
If sArray(j) > sTemp Then
sArray(j + 1) = sArray(j)
Else
Exit For
End If
Next j
sArray(j + 1) = sTemp
Next i

End Sub 'SortStrings