Give unique reference to each unique value - vba

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

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

Answer 3

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)