Another Code Please!

[Dazzawm]

I need a code that when I select a column if a word i.e ABC or a number i.e 123 appears anywhere within a cell more than once I would like all duplicates removed just leaving the one.

e.g

Cell A1 Before

ABC 123 123 ABC ABC 456 DEF

Cell A1 After

ABC 123 456 DEF

and so on down every row until the last.

I will need to use this on more than one column so its best if the code works on the active column.

Thanks.

 

[hiker95]

dazwm,


Sample raw data before the macro, with the column selected:

Excel Workbook
	A
1	ABC 123 123 ABC ABC 456 DEF
2
3	234 nmn 12 12 VGTH VGTH 234
4	2AD-FTV 2AD-FHV 2AD-FTV 2AD-FHV 2AD-FTV
5
Sheet1

After the macro, with the column selected:

Excel Workbook
	A
1	ABC 123 456 DEF
2
3	234 nmn 12 VGTH
4	2AD-FTV 2AD-FHV
5
Sheet1

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).


1. Copy the below code, by highlighting the code and pressing the keys CTRL + C
2. Open your workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code by pressing the keys CTRL + V
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel, open the workbook, and press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Option Explicit
Option Compare Text
Sub GetUnique()
' hiker95, 07/09/2011
' http://www.mrexcel.com/forum/showthread.php?t=563153
Dim a As Long, SC As Long, LR As Long
Dim u
Application.ScreenUpdating = False
SC = Selection.Column
LR = Cells(Rows.Count, SC).End(xlUp).Row
For a = 1 To LR Step 1
  If Cells(a, SC) <> "" Then
    u = unique(Cells(a, SC))
    Cells(a, SC) = u
  End If
Next a
Application.ScreenUpdating = True
End Sub

Function unique(ByVal rng As Range) As Variant
' hiker95, 07/09/2011
' http://www.mrexcel.com/forum/showthread.php?t=563153
' Original Functions by Weaver, 06/23/2011
' http://www.mrexcel.com/forum/showthread.php?t=559340
Dim d As Object, c
Dim i
Dim Sp
Set d = CreateObject("scripting.dictionary")
Sp = Split(rng, " ")
For i = LBound(Sp) To UBound(Sp)
  c = Sp(i)
  If Not d.exists(c) Then d.Add c, 1
Next i
unique = Join(d.keys, " ")
End Function

With the column selected, run the GetUnique macro.

 

[MARK858]

hiker95, just want to say "cool code". Filed for future reference.

 

[hiker95]

MARK858,

Thank you very much.