ExcelBanter - Delete Duplicate codes in a cell

It is complicated need a macro.

Sub removedups()
Dim MyArray()

Set tmpsht = Sheets.Add

Set MyRange = Application.InputBox(Prompt:="Select Range of cells", _
Title:="Input Cells", _
Type:=8)

For Each cell In MyRange
tmpsht.Cells.ClearContents
Set MyCell = Nothing
'split cellaround coomas
MyCell = Split(cell, ",")

With tmpsht
'put data into temp sheet
RowCount = 1
For Each word In MyCell
.Range("A" & RowCount) = word
RowCount = RowCount + 1
Next word

LastRow = .Range("A" & RowCount).End(xlUp).Row

'copy unique values to column B
.Range("A1:A" & LastRow).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("B1"), _
Unique:=True

If .Range("B1") = .Range("B2") Then
.Range("B1").Delete shift:=xlUp
End If
LastRow = .Range("B" & RowCount).End(xlUp).Row
'Sort Data
.Range("B1:B" & LastRow).Sort _
Header:=xlNo, _
key1:=.Range("b1"), _
Order1:=xlAscending

'put data back into an arra
ReDim MyArray(0 To (LastRow - 1))
For RowCount = 1 To LastRow
MyArray(RowCount - 1) = Range("B" & RowCount)
Next RowCount
End With

cell.Offset(0, 1) = Join(MyArray, ",")
Next cell

Application.DisplayAlerts = False
tmpsht.Delete
Application.DisplayAlerts = True

End Sub

"Mat" wrote:

Hi Everyone,

I have cell data, arranged in rows arranged entirely in one column, each
cell contain many codes. Ideally each cell should have a unique set of codes
(could be more than one).

I would like to eliminate all the duplicate codes and keep only one of each
code.

The example cells are as follows;

FA,FA,FS,FS,FZ
FO,FA,FS,FO
FO,FO,FO

Does anyone have any idea as to what I might do in order to make the
following happen:

1) FA,FS,FZ
2) FO,FA,FS
3) FO

Any suggestions are sincerely appreciated.

Thanks Mat