Give unique reference to each unique value

Question

I have an excel table that has some duplicates and we currently have a count of these however I want to populate a unique number for each duplicate. e.g.

Number  Count   Sequence
1          2    1
1          2    1
2          3    2
2          3    2
2          3    2
3          4    3
3          4    3
3          4    3
3          4    3
4          2    4
4          2    4
5          5    5
5          5    5
5          5    5
5          5    5
5          5    5

I was playing with the following IF statement but I want it to check through the whole range and check if it has any in a wrong order but still the same.

=IF(IF(IF(A2=A1,TRUE,FALSE)=FALSE,1,0)>=0,IF(IF(A2=A1,TRUE,FALSE)=FALSE,1,0)+D1,IF(IF(A2=A1,TRUE,FALSE)=FALSE,1,0))

is this possible?

Answer 1

It will add the unique ref into the a Column which is 3 columns up from what every you set col equal to.

It also requires that col + 3 to be blank, this will make the checking easier.

Sub SomeSub()

    Dim Array1 As Variant
    Dim Array2 As Variant

    With ActiveSheet.UsedRange
        LastRow = .Rows(.Rows.Count).Row
    End With

    'Setting up the array for assigning each row value to the array
    ReDim Array1((LastRow + 1))
    ReDim Array2((LastRow + 1))

    'Here youwill set what column is the "Number" Column
    col = 1

    'Assigning the row data into the arrays
    'Starting at 2 to skip the title row
    For r = 2 To LastRow
            'Values in Column 1 go to Array1
            Array1(r) = Cells(r, col)
            'Values in Column 2 go to Array2
            Array2(r) = Cells(r, col + 1)
    Next r

    'Setting unquie ref to 1
    Seq = 1
    'Running through each row of data
    For i = 2 To LastRow

        'col + 3 refers to a column on beyond the Sequence colum
        'If the column is blank then that row has not been checked yet
        If Cells(i, col + 3) = "" Then

            'Assign the Uniqui ref to the row
            Cells(i, col + 3).Value = Seq

            'Running through the rest of the rows to check if they are like the current row
            For n = i + 1 To (LastRow)

                'If cell is blank then the row has been checked
                If Cells(n, col + 3) = "" Then

                    'Array(i) is the current row
                    'Array(n) are the leading rows after row i
                    'If the current row is the same as any leading row then the uniquie ref = seq
                    If Array1(i) = Array1(n) And Array2(i) = Array2(n) Then Cells(n, col + 3).Value = Seq

                'Else a value has been added
                Else

                    'Do nothing

                End If

            Next n

            'Increment the seq
            Seq = Seq + 1

        'Ending the If Cells(i, col + 3) = "" Then
        End If

    Next i

End Sub

Answer 2

In C1 just 1 and in C2:

=MIN(IF(($A$2:A2=A3)*($B$2:B2=B3),$D$2:D2,MAX($D$2:D2)+1))

This is an array formula and must be confirmed with Ctrl+Shift+Enter.

and simply autofill down from C3

hmm... i think i got it wrong :/

if only looking at Column A then this should be enough:

=MIN(IF($A$2:A2=A3,$D$2:D2,MAX($D$2:D2)+1))

This is an array formula and must be confirmed with Ctrl+Shift+Enter.

looking at your formula it can be shortened:

=IF(IF(IF(A2=A1,TRUE,FALSE)=FALSE,1,0)>=0,IF(IF(A2=A1,TRUE,FALSE)=FALSE,1,0)+D1,IF(IF(A2=A1,TRUE,FALSE)=FALSE,1,0))
  'IF(A2=A1,TRUE,FALSE)=FALSE ==>> A1<>A2    
=IF(IF(A1<>A2,1,0)>=0,IF(A1<>A2,1,0)+D1,IF(A1<>A2,1,0))
  'IF(A1<>A2,1,0)>=0 ==>> TRUE
=IF(TRUE,IF(A1<>A2,1,0)+D1,IF(A1<>A2,1,0))
  'IF(TRUE => allways true
=IF(A1<>A2,1,0)+D1
  'last skip
=D1+(A1<>A2)

Answer 3

You can first loop through the column and get the unique items using collections.

This part of the code:

   On Error Resume Next
        For Each Cell In Rng.Cells
            cUnique.Add Cell.Value, CStr(Cell.Value)
        Next Cell

Will only get the unique items, as a collection of items cannot have duplicates.

Use this to Number the duplicates.Change the sheet name as required.

    Sub NumberDupes()
    Dim cUnique As Collection
    Dim Rng As Range
    Dim Cell As Range
    Dim sh As Worksheet
    Dim vNum As Variant
    Dim LstRw As Long
    Dim c As Long, clr As Long, x, r As Range

    Set sh = Sheets("Sheet2")
    With sh
        .Columns("B:B").ClearContents
        LstRw = .Cells(.Rows.Count, "A").End(xlUp).Row
        Set Rng = .Range(.Cells(2, 1), .Cells(LstRw, 1))
        Set cUnique = New Collection
        Rng.Interior.ColorIndex = xlNone
        clr = 1

        On Error Resume Next
        For Each Cell In Rng.Cells
            cUnique.Add Cell.Value, CStr(Cell.Value)
        Next Cell
        On Error GoTo 0

        For Each vNum In cUnique
            For c = 1 To LstRw
                Set r = .Cells(c, 1)
                x = Application.WorksheetFunction.CountIf(.Range(.Cells(1, 1), .Cells(c, 1)), r)
                If r = vNum Then
                    If x > 1 Then
                        r.Offset(, 1) = clr
                    End If
                End If
            Next c
            clr = clr + 1
        Next vNum

    End With

End Sub

Use this to Color the Duplicates, this will work on a small scale, depends on how many unique items there are, it's cool example though. Edited code from my answer here.

Sub ColorDupes()
    Dim cUnique As Collection
    Dim Rng As Range
    Dim Cell As Range
    Dim sh As Worksheet
    Dim vNum As Variant
    Dim LstRw As Long
    Dim c As Long, clr As Long, x, r As Range

    Set sh = Sheets("Sheet2")
    With sh

        LstRw = .Cells(.Rows.Count, "A").End(xlUp).Row
        Set Rng = .Range(.Cells(2, 1), .Cells(LstRw, 1))
        Set cUnique = New Collection
        Rng.Interior.ColorIndex = xlNone
        clr = 3

        On Error Resume Next
        For Each Cell In Rng.Cells
            cUnique.Add Cell.Value, CStr(Cell.Value)
        Next Cell
        On Error GoTo 0

        For Each vNum In cUnique
            For c = 1 To LstRw
                Set r = .Cells(c, 1)
                x = Application.WorksheetFunction.CountIf(.Range(.Cells(1, 1), .Cells(c, 1)), r)
                If r = vNum Then
                    If x > 1 Then
                        r.Interior.ColorIndex = clr
                    End If
                End If
            Next c
            clr = clr + 1
        Next vNum

    End With

End Sub