Unique values using Dictionary with criteria

[leterrier]

I have a spreadsheet with 3 columns. Column A contains product type names with the range named as "Product".Column B is a description of the product names and Column C contains supplier names with the range named as "supplier".


I'm using a macro based on a Dictionary object to extract a list of unique supplier names from column C but now wish to modify it so that I can extract a unique list of suppliers based on the Product type. In other words, if product type is "some product", show me a list of its unique suppliers. A sample of the code is below. It's based on a reply to a related question on the Stackoverflow forum by user Issun (thanks).


I hope I've explained clearly. Thank you in advance for your help!

Sub UniqueRep()


Dim dict1 As Object
Set dict1 = CreateObject("scripting.dictionary")
Dim var1 As Variant, element As Variant


var1 = Range("supplier").Value


'Generate unique list and count occurrences


For Each element In var1
    If dict.1exists(element) Then
        dict1.Item(element) = dict1.Item(element) + 1
    Else
        dict1.Add element, 1
    End If
Next


'Paste report data
Sheet2.Range("A1").Resize(dict1.Count, 1).Value = _
    WorksheetFunction.Transpose(dict1.keys)
Sheet2.Range("B1").Resize(dict1.Count, 1).Value = _
    WorksheetFunction.Transpose(dict1.items)


End Sub

 

[Norie]

All you should need to do is check if the supplier stocks/sells the product which you are concerned with.

You should be able to do that with a simple if statement, something like this perhaps.

Sub UniqueRep()
Dim dict1 As Object
Dim sup As Range
Dim strProduct As String

    strProduct = "NameOfProduct"
    
    Set dict1 = CreateObject("scripting.dictionary")

    For Each sup In Range("supplier").Value

        If sup.Offset(, -2) = strProduct Then
            If dict1.exists(sup.Value) Then
                dict1.Item(sup.Value) = dict1.Item(sup.Value) + 1
            Else
                dict1.Add sup.Value, 1
            End If
        End If
    Next sup

    'Paste report data
    Sheet2.Range("A1").Resize(dict1.Count, 1).Value = _
    WorksheetFunction.Transpose(dict1.keys)
    Sheet2.Range("B1").Resize(dict1.Count, 1).Value = _
    WorksheetFunction.Transpose(dict1.items)

End Sub

 

[leterrier]

Norie, thank you, I'll give it a try and let you know, thanks again!

 

[leterrier]

Norie,

I tried your solution but I get a "run time error 424 object required" message at the line below

For Each sup In Range("supplier").Value

 

[leterrier]

Norie,

It worked perfectly when I removed the ".value" from the end of the line! Thank you for all your help!!

 

[Norie]

Oops, remove .Value.

 

[Norie]

Oops, you've already spotted my deliberate mistake.

 

[leterrier]

Norie, thank you once more, one final question if you don't mind, could I modify your code so that StrProduct is initialised by reference to an existing range or a drop down list? I have tried but I'm getting a type mis-match error when I try to paste the resulting values at the end of the code - any ideas? Thanks!!!

 

[Norie]

I don't see why that shouldn't be possible, can you post what you tried and indicate where you received the error(s)?

 

[leterrier]

Norie,

Thank you so much, my code is below. When the strProduct variable is given a "text" value it works, if I try to give it a range value, it doesn't. Thanks!

Sub UniqueRep()
 
 Dim dict As Object
 Dim sup As Range
 Dim strProduct As String



If Sheet5.Name <> ActiveSheet.Name Then Exit Sub


    strProduct = "Paper" ' this works fine
    'strProduct = Range("G1").Value '(this causes a type-mis match error, Range("G1").text or Range("G1") don't work either)


     Set dict = CreateObject("scripting.dictionary")
     dict.CompareMode = vbTextCompare
     For Each sup In Range("supplier")
         If sup.Offset(, -2) = strProduct Then
             If dict.exists(sup.Value) Then
                 dict.Item(sup.Value) = dict.Item(sup.Value) + 1
             Else
                 dict.Add sup.Value, 1
             End If
         End If
     Next sup
     
'remove blanks and multi-supplier entries from supplier list
If dict.exists("") Then dict.Remove ("")
If dict.exists("Various") Then dict.Remove ("Various")



'Paste report data
Sheet5.Range("A5").Resize(dict.Count, 1).Value = _
WorksheetFunction.Transpose(dict.keys) 'XXXXXX Run time 13 type mis-match error is here XXXXXX
     
Sheet5.Range("B5").Resize(dict.Count, 1).Value = _
WorksheetFunction.Transpose(dict.items)

 End Sub