Unique values using Dictionary with criteria

leterrier

New Member
Joined
Jan 5, 2013
Messages
44
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!
Code:
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
 
Last edited by a moderator:

Some videos you may like

Excel Facts

What does custom number format of ;;; mean?
Three semi-colons will hide the value in the cell. Although most people use white font instead.

Norie

Well-known Member
Joined
Apr 28, 2004
Messages
76,216
Office Version
  1. 365
Platform
  1. Windows
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.
Code:
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

New Member
Joined
Jan 5, 2013
Messages
44
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

New Member
Joined
Jan 5, 2013
Messages
44

ADVERTISEMENT

Norie,

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

Norie

Well-known Member
Joined
Apr 28, 2004
Messages
76,216
Office Version
  1. 365
Platform
  1. Windows
Oops, remove .Value.
 

Norie

Well-known Member
Joined
Apr 28, 2004
Messages
76,216
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

Oops, you've already spotted my deliberate mistake.:)
 

leterrier

New Member
Joined
Jan 5, 2013
Messages
44
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

Well-known Member
Joined
Apr 28, 2004
Messages
76,216
Office Version
  1. 365
Platform
  1. Windows
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

New Member
Joined
Jan 5, 2013
Messages
44
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!

Code:
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
 

Watch MrExcel Video

Forum statistics

Threads
1,122,216
Messages
5,594,886
Members
413,947
Latest member
gizmolucy

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top