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
|