Macro to delete duplicate numbers in a cell?

sirenetta1 · Mar 16, 2005

Hello,

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

Code:

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!

BrianB · Mar 17, 2005

Perhaps this will help. It sorts on clumn 1 and checks for duplicates there.

Code:

'---------------------------------------------------------------
'- MACRO TO REMOVE DUPLICATE ROWS
'- assumes headings in row 1
'- sorting on & checking column 1 for duplicates
'- Brian Baulsom 15th.October 1999
'----------------------------------------------------------------
Sub DeleteDuplicateRows()
    Dim ws As Worksheet
    Dim CheckRow As Long
    Dim LastRow As Long
    '-----------------------------------
    Application.Calculation = xlCalculationManual
    Set ws = ActiveSheet
    CheckRow = 2
    LastRow = ws.Range("A65536").End(xlUp).Row
    '- sort
    Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, _
        Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom
    '- check rows
    Do
        If ws.Cells(CheckRow, 1).Value = _
                ws.Cells(CheckRow + 1, 1).Value Then
            ws.Rows(CheckRow + 1).EntireRow.Delete
            LastRow = LastRow - 1
        Else
            CheckRow = CheckRow + 1
        End If
    Loop While CheckRow <= LastRow
    Application.Calculation = xlCalculationAutomatic
End Sub
'-----------------------------------------------------------------------

sirenetta1 · Mar 17, 2005

Need another solution...

Hi Brian,

Thanks for your code, but it's not what I'm looking for. I'm trying to get duplicate numbers removed from "within" the cell, and I don't want to delete any of my rows during the "duplicate removal" process because I need them.

My solution would have to be a macro that it sorts all numbers within a cell (see Tom's macro) and then after it sorts all of the numbers within a cell, it removes all duplicates.

EXAMPLE: I have 3 cells that read:

3,2,2,1,6 -- 1,7,8,2,2,4 -- 1,5,3,2,1

After I click on the macro, the cells would now read:

1, 2, 3, 6 -- 1, 2, 4, 7, 8 -- 1, 2, 3, 5

Thanks!

Tom Urtis · Mar 17, 2005

Based on the number sequences in the strings you posted above, this would do that:

Sub Test1()
With Application
.ScreenUpdating = False
.DisplayAlerts = False
Dim asn$, aca$, straca$, iCol%, iColL%
Dim 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

iColL = Cells(1, 256).End(xlToLeft).Column
For iCol = iColL To 2 Step -1
If .CountIf(Rows(1), Cells(1, iCol).Value) > 1 Then
Cells(1, iCol).Delete xlShiftToLeft
End If
Next iCol

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

sirenetta1 · Mar 17, 2005

GREAT!

Tom,

Thanks for your help again!! It works great!!!

I have one last question for you, some of my numbers are like this:

12-4, 13-7, 3-6

When I run your macro, they turn into dates.

The only way I've found to fix it, is to turn the dashes into periods, run the macro, and then turn the periods back to dashes.

Is there anyway that the macro could be adjusted to read these numbers and not turn them into dates when sorting?

Thanks!

Tom Urtis · Mar 17, 2005

Did you test the code I posted here
http://www.mrexcel.com/board2/viewtopic.php?t=134650&postdays=0&postorder=asc&start=10
where you asked the same question?

It worked for me, all you'd need to do is plug in the changes reflected there into the macro I posted in this thread here.

jindon · Mar 17, 2005

UDF

Code:

Function SortC(r As Range) As String
Dim dic As Object, i As Integer, ii As Integer
Dim a() As Double, b(), nbr, txt
Dim MINnbr As Double, x, iii As Integer
Set dic = CreateObject("Scripting.Dictionary")
txt = Application.Substitute(r, " ", "")
If InStr(r, ",") > 0 Then
    nbr = Split(txt, ",")
    ii = -1
    For i = LBound(nbr) To UBound(nbr)
        If Not dic.exists(nbr(i)) Then: dic.Add nbr(i), Nothing
        ii = ii + 1: ReDim Preserve a(ii): a(ii) = Val(nbr(i))
    Next
    x = dic.keys
    For i = LBound(x) To UBound(x)
        MINnbr = Application.Min(a): Erase a
        ReDim Preserve b(i): b(i) = MINnbr: iii = -1
        For ii = LBound(x) To UBound(x)
            If x(ii) > MINnbr Then
                iii = iii + 1: ReDim Preserve a(iii): a(iii) = x(ii)
            End If
        Next
    Next
    SortC = Join(b, ", ")
    Set dic = Nothing: Erase a, b, x
End If
End Function

sirenetta1 · Mar 18, 2005

Jindon,

Thanks for your function example, but I'm afraid I don't know how to use functions? Whenever I apply the function to a cell, it tries to create some code inside. I just need the information in the cell sorted. I found that applying a macro to the cell works great, but if you could explain to me more how to use the function, that would be nice, too!

Thanks!

jindon · Mar 18, 2005

sirenetta1,

1) Alt + F11 to get VB editor to open
2) go to Insert -> Standard Module and paste the code onto the right side.
3) Alt + F11 to get back to excel.

Use like in the cell

=sortc(A1)

will give you sorted results, but it doesn't work for 11-2, 22-2 thing.
will adjust the code later.

do you have combined data like
2, 3, 11-2, 5, 12-4, 15, 10
??

jindon · Mar 19, 2005

try
paste the code onto standard module
and in cell
=sortC(A1,"ConjunctionString")
where conjunction string is like "_", ":", "/"...etc
if you don't fill conjunction string then "-" will apply as a default

Code:

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, conj) = 0 Then: sortC = sortC2(r): Exit Function
If InStr(r, ",") > 0 Then
    nbr = Split(txt, ","): txt = ""
    ii = -1
    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: ii = -1
    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
Function sortC2(ByRef r As String) As String
Dim dic As Object, i As Integer, ii As Integer
Dim a() As Double, b(), nbr, txt
Dim MINnbr As Double, x, iii As Integer
Set dic = CreateObject("Scripting.Dictionary")
txt = Replace(r, " ", "")
If InStr(r, ",") > 0 Then
    nbr = Split(txt, ",")
    ii = -1
    For i = LBound(nbr) To UBound(nbr)
        If Not dic.exists(nbr(i)) Then: dic.Add nbr(i), Nothing
        ii = ii + 1: ReDim Preserve a(ii): a(ii) = Val(nbr(i))
    Next
    x = dic.keys
    For i = LBound(x) To UBound(x)
        MINnbr = Application.Min(a): Erase a
        ReDim Preserve b(i): b(i) = MINnbr: iii = -1
        For ii = LBound(x) To UBound(x)
            If x(ii) > MINnbr Then
                iii = iii + 1: ReDim Preserve a(iii): a(iii) = x(ii)
            End If
        Next
    Next
    txt = Join(b, ", ")
    sortC2 = txt
    Set dic = Nothing: Erase a, b, x
End If
End Function

Macro to delete duplicate numbers in a cell?

sirenetta1

Board Regular

Excel Facts

BrianB

Well-known Member

sirenetta1

Board Regular

Tom Urtis

MrExcel MVP

sirenetta1

Board Regular

Tom Urtis

MrExcel MVP

jindon

MrExcel MVP

sirenetta1

Board Regular

jindon

MrExcel MVP

jindon

MrExcel MVP

Similar threads

Forum statistics

Share this page

Macro to delete duplicate numbers in a cell?

Board Regular

Excel Facts

Well-known Member

Board Regular

MrExcel MVP

Board Regular

MrExcel MVP

MrExcel MVP

Board Regular

MrExcel MVP

MrExcel MVP

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock