Macro to delete duplicate numbers in a cell?

[sirenetta1]

Hello,

Tom Urtis posted and helped me solve my problem on how to sort numbers in cells by using this macro (thanks Tom!):

Sub Test2() 

With Application 
.ScreenUpdating = False 
.DisplayAlerts = False 
Dim asn$, aca$, straca$, cell As Range, CommaCell As Range 
asn = ActiveSheet.Name 

For Each cell In Selection 

If InStr(cell, ",") > 0 Then 
aca = cell.Address 
straca = Range(aca).Value 
Sheets.Add 
Range("A1").Value = straca 
Range("A1").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _ 
ConsecutiveDelimiter:=True, Tab:=True, Comma:=True, Space:=True, _ 
FieldInfo:=Array(Array(1, 1)) 
Range("A1").Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlNo, _ 
OrderCustom:=1, MatchCase:=False, Orientation:=xlLeftToRight 
For Each CommaCell In Rows(1).SpecialCells(2) 
Range("A2").Value = Range("A2").Value & CommaCell.Value & ", " 
Next CommaCell 
Range("A3").Formula = "=LEFT(R2C1,LEN(R2C1)-2)" 
Sheets(asn).Range(aca).Value = Range("A3").Value 
ActiveSheet.Delete 
End If 

Next cell 

.Goto ThisWorkbook.Worksheets(asn).Range("A1"), True 
.DisplayAlerts = True 
.ScreenUpdating = True 
End With 
End Sub

This worked really well. My question is, is there a way for the macro to also delete duplicate numbers after sorting?

Example:

BEFORE SORTING:

1, 4, 3, 3, 2, 1, 6

CLICK MACRO:

1, 2, 3, 4, 5, 6

Thanks!

 

[jindon]

found this code alone will do the job

Function sortC(r As String, Optional conj As String = "-") As String
Dim dic As Object, i As Integer, ii As Integer
Dim a As Variant, b(), nbr, txt, c(), z
Dim MINnbr As Double, x, iii As Integer
Set dic = CreateObject("Scripting.Dictionary")
txt = Replace(r, " ", "")
If InStr(r, ",") > 0 Then
    nbr = Split(txt, ","): txt = ""
    For Each z In nbr
        If InStr(z, conj) = 0 Then
          If Not dic.exists(z) Then
              dic.Add z, 0 & ","
            Else
                If Left(dic.Item(z), 1) <> "0" Then
                    dic.Item(z) = 0 & "," & dic.Item(z)
                End If
          End If
        Else
            xl = Left(z, InStr(z, conj) - 1): xr = Right(z, Len(z) - InStr(z, conj))
            If Not dic.exists(xl) Then
                dic.Add xl, xr & ","
            Else
                dic.Item(xl) = dic.Item(xl) & xr & ","
            End If
        End If
    Next
    x = dic.keys: y = dic.items: ReDim a(UBound(x)): i = -1: ii = -1
    For Each z In x: i = i + 1: a(i) = Val(z): Next
    For i = LBound(x) To UBound(x)
        MINnbr = Application.Min(a): Erase a
        ii = ii + 1: ReDim Preserve b(ii): b(ii) = MINnbr: iv = -1
        For iii = LBound(x) To UBound(x)
            If Val(x(iii)) > MINnbr Then
                iv = iv + 1: ReDim Preserve a(iv): a(iv) = Val(x(iii))
            End If
        Next
    Next
    Erase a
    For i = LBound(y) To UBound(y)
        If y(i) <> "0," Then
            z = y(i): ii = -1
            yra = Split(Left(z, Len(z) - 1), ",")
            For Each z2 In yra
                ii = ii + 1: ReDim Preserve a(ii): a(ii) = Val(z2)
            Next
            iii = -1
            For ii = LBound(a) To UBound(a)
                If Application.Sum(a) = 0 Then: y(i) = "0,": GoTo skip
                MINnbr = Application.Min(a): iii = iii + 1
                ReDim Preserve c(iii): c(iii) = MINnbr
                    For iv = LBound(a) To UBound(a)
                        If a(iv) <= MINnbr Then a(iv) = ""
                    Next
            Next
            y(i) = Join(c, ","): Erase a, yra
skip:
        End If
    Next
    For i = LBound(b) To UBound(b)
        For ii = LBound(x) To UBound(x)
            If b(i) = Val(x(ii)) Then
                If y(ii) <> "0," Then
                    nbr = Split(y(ii), ",")
                    For iv = LBound(nbr) To UBound(nbr)
                        If nbr(iv) = 0 Then
                            txt = txt & x(ii) & ", "
                        Else
                            txt = txt & x(ii) & conj & nbr(iv) & ", "
                        End If
                    Next
                Else
                    txt = txt & x(ii) & ", ": Exit For
                End If
            End If
        Next
    Next
    txt = Left(txt, Len(txt) - 2)
    sortC = txt
    Set dic = Nothing: Erase a, b, x, c
End If
End Function

 

[sirenetta1]

Hi Jindon,

Yes, I do at times have a string of numbers like:

3, 2, 12-34, 1, 7, 13

I appreciate your help with this!! I will take a look at your code!

 

[jindon]

sirenetta1,

I should have declared all the variables.

can you swap the first 4 lines with the following code?

Public Function sortC(r As String, Optional conj As String = "-") As String
Dim dic As Object, i As Integer, ii As Integer, txt As String
Dim a As Variant, b(), nbr, c(), z, z2, xl, xr, iv As Integer
Dim MINnbr As Double, x, y, yra, iii As Integer

 

[jindon]

found bug
thr former code doesn't sort if the cell has duplicate in 1-1,1-1
change to the following
I hope this is the final modification

Public Function sortC(r As String, Optional conj As String = "-") As String
Dim dic As Object, i As Integer, ii As Integer, txt As String
Dim a As Variant, b(), nbr, c(), z, z2, xl, xr, iv As Integer
Dim MINnbr As Double, x, y, yra, iii As Integer
Set dic = CreateObject("Scripting.Dictionary")
txt = Replace(r, " ", ""): nbr = Split(txt, ",")
If InStr(r, ",") > 0 Then
    For Each z In nbr
        If Not dic.exists(z) Then dic.Add (z), Nothing
    Next
    nbr = dic.keys: txt = "": x = dic.removeall
    For Each z In nbr
        If InStr(z, conj) = 0 Then
          If Not dic.exists(z) Then
              dic.Add z, 0 & ","
            Else
                If Left(dic.Item(z), 1) <> "0" Then
                    dic.Item(z) = 0 & "," & dic.Item(z)
                End If
          End If
        Else
            xl = Left(z, InStr(z, conj) - 1): xr = Right(z, Len(z) - InStr(z, conj))
            If Not dic.exists(xl) Then
                dic.Add xl, xr & ","
            Else
                dic.Item(xl) = dic.Item(xl) & xr & ","
            End If
        End If
    Next
    x = dic.keys: y = dic.items: ReDim a(UBound(x)): i = -1: ii = -1
    For Each z In x: i = i + 1: a(i) = Val(z): Next
    For i = LBound(x) To UBound(x)
        MINnbr = Application.Min(a): Erase a
        ii = ii + 1: ReDim Preserve b(ii): b(ii) = MINnbr: iv = -1
        For iii = LBound(x) To UBound(x)
            If Val(x(iii)) > MINnbr Then
                iv = iv + 1: ReDim Preserve a(iv): a(iv) = Val(x(iii))
            End If
        Next
    Next
    Erase a
    For i = LBound(y) To UBound(y)
        If y(i) <> "0," Then
            z = y(i): ii = -1
            yra = Split(Left(z, Len(z) - 1), ",")
            For Each z2 In yra
                ii = ii + 1: ReDim Preserve a(ii): a(ii) = Val(z2)
            Next
            iii = -1
            For ii = LBound(a) To UBound(a)
                If Application.Sum(a) = 0 Then: y(i) = "0,": GoTo skip
                MINnbr = Application.Min(a): iii = iii + 1
                ReDim Preserve c(iii): c(iii) = MINnbr
                    For iv = LBound(a) To UBound(a)
                        If a(iv) <= MINnbr Then a(iv) = ""
                    Next
            Next
            y(i) = Join(c, ","): Erase a, yra
skip:
        End If
    Next
    For i = LBound(b) To UBound(b)
        For ii = LBound(x) To UBound(x)
            If b(i) = Val(x(ii)) Then
                If y(ii) <> "0," Then
                    nbr = Split(y(ii), ",")
                    For iv = LBound(nbr) To UBound(nbr)
                        If nbr(iv) = 0 Then
                            txt = txt & x(ii) & ", "
                        Else
                            txt = txt & x(ii) & conj & nbr(iv) & ", "
                        End If
                    Next
                Else
                    txt = txt & x(ii) & ", ": Exit For
                End If
            End If
        Next
    Next
    txt = Left(txt, Len(txt) - 2)
    sortC = txt
    Set dic = Nothing: Erase a, b, x, c
End If
End Function