Updated YES!! another counting of unique entries:)

**2001jesper** · 04-14-2013, 06:37 AM

Good morning everybody

iam trying to create a counting of unique combination. Iam doing this using =IF(SUMPRODUCT(($A$5:$A7=A7)*($B$5:$B7=B7))>1;0;1) i.e this returns a 1 if the combination is unique and a 0 if it's a dublicate.

I need the 1's and 0's in order to get ratios for further calculations

This is normally not a problem, but this time i have 60.000 + lines and that makes excel crash.

my previous experience with coding WBA's is just a little over 3 minutes, but iam very good at CRTL+C, CRTL + V

I hope theres help out there, and i can offer a "like" as a trade

Thx in advance

**nilem** · 04-14-2013, 07:11 AM

Hi 2001jesper,
try it

Sub ertert()
Dim x, y(), i&
x = Range("A5:D" & Cells(Rows.Count, 1).End(xlUp).Row).Value
ReDim y(1 To UBound(x), 1 To 3)
With CreateObject("Scripting.Dictionary")
    .CompareMode = 1
    For i = 1 To UBound(x)
        If .Exists(x(i, 1) & "~" & x(i, 2)) Then y(i, 1) = 0 Else y(i, 1) = 1: .Item(x(i, 1) & "~" & x(i, 2)) = Empty
        If .Exists(x(i, 1) & "~" & x(i, 3)) Then y(i, 2) = 0 Else y(i, 2) = 1: .Item(x(i, 1) & "~" & x(i, 3)) = Empty
        If .Exists(x(i, 1) & "~" & x(i, 4)) Then y(i, 3) = 0 Else y(i, 3) = 1: .Item(x(i, 1) & "~" & x(i, 4)) = Empty
    Next i
End With
Range("F5:H5").Resize(i - 1).Value = y()
End Sub

**2001jesper** · 04-14-2013, 08:16 AM

Thank you so much, it almost worked.

But when i tested on large scale and copied to my main sheet, it showed the wrong results. It gave me 1's in the first row and then zero's in the Rest

It seems to fail when all 4 input rows are the same / or russian sign are in - i dont know.

I hope theres anyone out there who can tweak the code with a small fix, it will be very appriciated

Thx in Advance

**2001jesper** · 04-14-2013, 01:12 PM

bump bump bump

**nilem** · 04-14-2013, 11:09 PM

Let's add tildes (not Russian sign

)
try it

Sub ertert()
Dim x, y(), i&
x = Range("A5:D" & Cells(Rows.Count, 1).End(xlUp).Row).Value
ReDim y(1 To UBound(x), 1 To 3)
With CreateObject("Scripting.Dictionary")
    .CompareMode = 1
    For i = 1 To UBound(x)
        If .Exists(x(i, 1) & "~" & x(i, 2)) Then y(i, 1) = 0 Else y(i, 1) = 1: .Item(x(i, 1) & "~" & x(i, 2)) = Empty
        If .Exists(x(i, 1) & "~~" & x(i, 3)) Then y(i, 2) = 0 Else y(i, 2) = 1: .Item(x(i, 1) & "~~" & x(i, 3)) = Empty
        If .Exists(x(i, 1) & "~~~" & x(i, 4)) Then y(i, 3) = 0 Else y(i, 3) = 1: .Item(x(i, 1) & "~~~" & x(i, 4)) = Empty
    Next i
End With
Range("F5:H5").Resize(i - 1).Value = y()
End Sub