VBA Count Unique Values

Hi hobbiton73,
try

Sub ertert()
Dim x, i&, t()
x = Range("B8:D" & Cells(Rows.Count, 2).End(xlUp).Row).Value
Range("G2").CurrentRegion.ClearContents
With CreateObject("Scripting.Dictionary")
    .CompareMode = 1
    For i = 1 To UBound(x)
        If Not .Exists(x(i, 3)) Then
            .Item(x(i, 3)) = Array(x(i, 3), 1, "~" & x(i, 1) & "~")
        Else
            t() = .Item(x(i, 3))
            If InStr(t(2), "~" & x(i, 1) & "~") = 0 Then
                t(1) = t(1) + 1
                t(2) = t(2) & x(i, 1) & "~"
                .Item(x(i, 3)) = t()
            End If
        End If
    Next i
    Range("G2:H2").Resize(.Count) = Application.Index(.items, 0, 0)
End With
End Sub

Hi @nilem, thank you very much for taking the time to reply to my post and for the solution which works great.

May I just ask a couple of more things please.

• Would it be possible to paste the results on the "Desired Outcome" sheet in columns B and C starting at row 8 please, and

• Could you possibly insert some notes into the code please so I can learn from this.

Many thanks and kind regards

try again

Sub ertert()
Dim x, i&, t()
With Sheets("In Flight Projects")
    x = .Range("B8:D" & .Cells(Rows.Count, 2).End(xlUp).Row).Value
End With
With Sheets("Desired Outcome")
    .Range("B8:C" & .Cells(Rows.Count, 2).End(xlUp).Row + 1).ClearContents
End With
With CreateObject("Scripting.Dictionary")
    .CompareMode = 1
    For i = 1 To UBound(x)
        If Not .Exists(x(i, 3)) Then
            .Item(x(i, 3)) = Array(x(i, 3), 1, "~" & x(i, 1) & "~")
        Else
            t() = .Item(x(i, 3))
            If InStr(t(2), "~" & x(i, 1) & "~") = 0 Then
                t(1) = t(1) + 1
                t(2) = t(2) & x(i, 1) & "~"
                .Item(x(i, 3)) = t()
            End If
        End If
    Next i
    Sheets("Desired Outcome").Range("B8:C8").Resize(.Count) = Application.Index(.items, 0, 0)
End With
End Sub

Hi @nilem, thank you very much for taking the time to come back to me with this, it's works great.

Could I possibly trouble you to include some notes the code please, so I can learn how this works.

Many thanks and kind regards

Could you show your file in which an error occurs

Hi @nilem, thank you very much for taking the time to come back to me with this, I really appreciate it

Unfortunately I'm unable to post the file because of the confidential information contained within it. I know this isn't particularly helpful.

I've perfomed more tests, but to be honest I really can't determine why it's happening

Many thanks and kind regards

Hi @nilem, thank you very much for your continued help with this.

I've sent you a private message but I'm not sure whether it's work.

Just in case, I've managed to put together a file which illustrates the error.

• If you could please open the file and click the button you will see the error

• However, if you then change the values in column B on rows 11 and 12 to "Digitalisation", and then select the button again, the macro will work.

I'm not sure whether it's a memory buffer or number of characters issue.

For example if you reload the file and change the value in column B on the final role to "Universal" the macro will work.

I hope this helps.

Many thanks and kind regards

Here's your file. try again (I hope everything will turn out now )

Sub ertert()
Dim x, y(), i&, j&, t()
With Sheets("In Flight Projects")
    x = .Range("B8:D" & .Cells(Rows.Count, 2).End(xlUp).Row).Value
End With
With Sheets("Desired Outcome")
    .Range("B8:C" & .Cells(Rows.Count, 2).End(xlUp).Row + 1).ClearContents
End With
ReDim y(1 To UBound(x), 1 To 2)
With CreateObject("Scripting.Dictionary")
    .CompareMode = 1
    For i = 1 To UBound(x)
        If Not .Exists(x(i, 3)) Then
            j = j + 1
            .Item(x(i, 3)) = Array(j, "~" & x(i, 1) & "~")
            y(j, 1) = x(i, 3)
            y(j, 2) = 1
        Else
            t() = .Item(x(i, 3))
            If InStr(t(1), "~" & x(i, 1) & "~") = 0 Then
                t(1) = t(1) & x(i, 1) & "~"
                y(t(0), 2) = y(t(0), 2) + 1
                .Item(x(i, 3)) = t()
            End If
        End If
    Next i
    Sheets("Desired Outcome").Range("B8:C8").Resize(j) = y()
    Sheets("Desired Outcome").Activate
End With
End Sub

Hi @Leith Ross, thank you very much for taking the time to reply to my post and for putting the code together.

I've downloaded the file uyou kindly provide, but unfortunately, perhaps as you've been putting this together the values from column D have been overwritten.

If you perhaps have a moment please, you'll see that the original file contained a value in this column, which I then wanted to use on the "Desired Outcome" sheet against the number of times there was a unique entry in column B.

Many thanks and kind regards

Hi @Leith Ross, thank you very much for taking the time to come back to me with this.

I've downloaded the file you've kindly provided and unfortuately there is no change to the previous one you posted.

I have however tried your code in my live sheet and unfortuantely this doesn't quite provide the desired results. Rather than listing the unique entries from column D, the code lists the values from column B.

Many thanks and kind regards

Hi @BS Singh, thank you for taking the time to look at my post.

If it helps, although I too am looking forward to see the code annotations by @nilem, please find the full working code below:

Sub ertert()
Dim x, y(), i&, j&, t()
With Sheets("In Flight Projects")
    x = .Range("B8:D" & .Cells(Rows.Count, 2).End(xlUp).Row).Value
End With
With Sheets("Desired Outcome")
    .Range("B8:C" & .Cells(Rows.Count, 2).End(xlUp).Row + 1).ClearContents
End With
ReDim y(1 To UBound(x), 1 To 2)
With CreateObject("Scripting.Dictionary")
    .CompareMode = 1
    For i = 1 To UBound(x)
        If Not .Exists(x(i, 3)) Then
            j = j + 1
            .Item(x(i, 3)) = Array(j, "~" & x(i, 1) & "~")
            y(j, 1) = x(i, 3)
            y(j, 2) = 1
        Else
            t() = .Item(x(i, 3))
            If InStr(t(1), "~" & x(i, 1) & "~") = 0 Then
                t(1) = t(1) & x(i, 1) & "~"
                y(t(0), 2) = y(t(0), 2) + 1
                .Item(x(i, 3)) = t()
            End If
        End If
    Next i
    Sheets("Desired Outcome").Range("B8:C8").Resize(j) = y()
    Sheets("Desired Outcome").Activate
End With
End Sub

Many thanks and kind regards

Hi @Leith Ross, thank you for taking the time to come back to me with this and for the clear explanation.

I fell comfortable in making the changes.

If it help, I was also fortunate to receive an alternative working solution from @nilem which I've posted previously.

Many thanks and kind regards