Copy & Paste Unique Cells Values

Hi,

UDF
1) hit Alt + F11 to open VB Editor
2) go to Insert - > Module then paste code there
3) hit Alt + F11 again to get back to Excel

in cell B1
=sortcell(A1) or =sortcell(A1," ") ... second argument for delim chatcter

Function sortCell(txt As String, Optional delim As String = " ") As String
Dim dic As Object, x, a, i As Integer, ii As Integer

Set dic = CreateObject("Scripting.Dictionary")
a = Split(txt, delim)
For i = LBound(a) To UBound(a)
    If Not dic.exists(a(i)) Then
        dic.Add a(i), Nothing
    End If
Next
x = dic.keys: ReDim Preserve x(1 To dic.Count)
x = QuickSort(x, LBound(x), UBound(x))
sortCell = Join(x, delim)
End Function


Function QuickSort(Ary, SideA As Integer, SideB As Integer)
Dim i As Integer, ii As Integer
Dim m As Long, tmp As Long
    i = SideA
    ii = SideB
    m = Ary(Int((SideB + SideA) / 2))
    Do While i <= ii
        Do While Ary(i) < m
            i = i + 1
        Loop
        Do While m < Ary(ii)
            ii = ii - 1
        Loop
        If i <= ii Then
            tmp = Ary(i)
            Ary(i) = Ary(ii)
            Ary(ii) = tmp
            i = i + 1
            ii = ii - 1
        End If
    Loop
    If SideA < ii Then QuickSort = QuickSort(Ary, SideA, ii)
    If i < SideB Then QuickSort = QuickSort(Ary, i, SideB)
    QuickSort = Ary
End Function

Originally Posted by Michael168

Hi! VBA Expert here

I am looking for a module that read from G9:L(last row) and write the unique values into the cells M9:R (last row) with sorting left to right.

Few Examples :

G9:L14 M9:R14

4 5 3 3 4 5 = 3 4 5
2 2 3 6 7 0 = 0 2 3 6 7
7 4 9 8 2 3 = 2 3 4 7 8 9
7 9 9 0 1 8 = 0 1 7 8 9
7 1 6 8 6 6 = 1 6 7 8
6 7 9 1 7 6 = 1 6 7 9

I wish the above example is clear for you to help me.
Thanks for helping.

Regards,
Michael

Michael168,

My misunderstanding.

I thought the numbers are in "ONE CELL", so code in the previous post doen't work for you.

The following code should work.
Before you run the code, you need to select the range in question.
e.g. G9:L14

Sub test()
Dim rng As Range, i As Long, ii As Integer, a, dic As Object, x
Set dic = CreateObject("Scripting.Dictionary")
Set rng = Selection
With rng
    rw = .Rows.Count: col = .Columns.Count
    For i = 1 To rw
        For ii = 1 To col
            If Not IsEmpty(.Cells(i, ii)) And Not dic.exists(.Cells(i, ii).Value) Then
                dic.Add .Cells(i, ii).Value, Nothing
            End If
        Next
        x = dic.keys: ReDim Preserve x(1 To dic.Count)
        x = QuickSort(x, LBound(x), UBound(x))
        .Cells(i, col).Offset(, 1).Resize(, UBound(x)).Value = x
        a = dic.RemoveAll: Erase x
    Next
End With
End Sub

Function QuickSort(Ary, SideA As Integer, SideB As Integer)
Dim i As Integer, ii As Integer
Dim m As Long, tmp As Long
    i = SideA
    ii = SideB
    m = Ary(Int((SideB + SideA) / 2))
    Do While i <= ii
        Do While Ary(i) < m
            i = i + 1
        Loop
        Do While m < Ary(ii)
            ii = ii - 1
        Loop
        If i <= ii Then
            tmp = Ary(i)
            Ary(i) = Ary(ii)
            Ary(ii) = tmp
            i = i + 1
            ii = ii - 1
        End If
    Loop
    If SideA < ii Then QuickSort = QuickSort(Ary, SideA, ii)
    If i < SideB Then QuickSort = QuickSort(Ary, i, SideB)
    QuickSort = Ary
End Function