Random Sample w/Priority

Hello, i am looking for a 'best method' for this situation...(file attached).

The goal is to take ONE random sample for each unique Customer #.
However, 'Cars' take priority over other purchases (example: If the random purchase sample was an apple but the same customer# also bought a car, the random sample becomes the car).

My approach was going to be to copy a random customer# from the list to a new worksheet, then loop thru the original rows deleting matching Customer#'s while also checking for the car purchase. IF the car was purchased it would replace the copied row. in the end id be left with a unique list of customer#s, with all unique car purchases where applicable.


Can anyone think of a simpler solution for this type of scenario?

Try this for results on sheet2 starting "A1".

Sub MG25Jun30
Dim Rng As Range, Dn As Range, n As Long
Set Rng = Range("B2", Range("B" & Rows.Count).End(xlUp))
With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
For Each Dn In Rng
    If Not .Exists(Dn.Value) Then
        .Add Dn.Value, Dn.Offset(, -1).Value
    Else
        .Item(Dn.Value) = .Item(Dn.Value) & "," & Dn.Offset(, -1).Value
    End If
Next

Dim Num As Long, P As String, K As Variant, Sp As Variant, c As Long
ReDim Ray(1 To .Count + 2, 1 To 2)
Ray(1, 1) = "Item": Ray(1, 2) = "Cust #"
c = 1
For Each K In .keys
    Sp = Split(.Item(K), ",")
      Num = Application.RandBetween(0, UBound(Sp))
      P = IIf(InStr(.Item(K), "Car") > 0, "Car", Sp(Num))
            c = c + 1
            Ray(c, 1) = P: Ray(c, 2) = K
Next K
 Sheets("Sheet2").Range("A1").Resize(c, 2).Value = Ray

End With

End Sub

Regards Mick

@MickG - this works great. Unfortunately for me i have never seen RAY used & am finding trouble following(stepping doesnt show results until complete).
Can the dictionary be substituted for a simple 'remove duplicates" column in worksheet 2?.
Does the RAY method go hand in hand with .keys/dictionary?
...i'm just trying to dumb down your code for a person like me to troubleshoot if need be.

I've removed the Array "Ray" and added some notes.
If you step through it you should see what's happening !!
Hope that helps.

Sub MG25Jun34
Dim Rng As Range, Dn As Range, n As Long, Dic As Object
With Sheets("Sheet1")
    Set Rng = .Range("B2", .Range("B" & Rows.Count).End(xlUp))
End With

Set Dic = CreateObject("scripting.dictionary")
For Each Dn In Rng
    If Not Dic.Exists(Dn.Value) Then
        Dic.Add Dn.Value, Dn.Offset(, -1).Value
    Else
        Dic(Dn.Value) = Dic(Dn.Value) & "," & Dn.Offset(, -1).Value
    End If
Next
'NB: The Dictionary above just creates a Unique list of column "B" numbers
'with an adjacent list of all "Items Purchased" against that number.

Dim Num As Long, P As String, K As Variant, Sp As Variant, c As Long


With Sheets("Sheet2")
.Cells(1, 1) = "Item": .Cells(1, 2) = "Cust #"
c = 1

'Code loops the Unique number list
For Each K In Dic.keys
    Sp = Split(Dic(K), ",")
      Num = Application.RandBetween(0, UBound(Sp))
      P = IIf(InStr(Dic(K), "Car") > 0, "Car", Sp(Num))
            c = c + 1
            .Cells(c, 1) = P: .Cells(c, 2) = K
Next K
End With
End Sub

Regards Mick

Another option , No Dictionary and No array, Plus direct update on sheet2 !!

Sub MG25Jun38
Dim Rng As Range, Dn As Range, c As Long, R As Range, n As Long, Sp As Variant, Num As Long, P As String
With Sheets("Sheet1")
    Set Rng = .Range("B2", .Range("B" & Rows.Count).End(xlUp))
End With
c = 1
With Sheets("Sheet2")
.Columns("A:B").ClearContents
For Each Dn In Rng
    If Application.CountIf(Rng(1).Resize(Dn.Row), Dn.Value) = 1 Then
        c = c + 1
        .Cells(c, "A") = Dn.Value
            For Each R In Rng
                If R.Value = Dn.Value Then
                   .Cells(c, "B") = .Cells(c, "B") & IIf(.Cells(c, "B") = "", R.Offset(, -1), "," & R.Offset(, -1))
                End If
            Next R
    End If
Next Dn

.Cells(1, 1) = "Item": .Cells(1, 2) = "Cust #"
For n = 2 To c
  Sp = Split(.Cells(n, "B"), ",")
      Num = Application.RandBetween(0, UBound(Sp))
       P = IIf(InStr(.Cells(n, "B"), "Car") > 0, "Car", Sp(Num))
        .Cells(n, "B") = P
Next n

End With
End Sub

Regards Mick

Mick - If i were to need the randomized item VALUE returned (instead of "Car"), does that throw a wrench in this code?

@Mick - Thank you very much these have all been helpful!

Mick - Thanks for the quick reply. Just to confirm, when i choose random it is likely that a Car purchase is going to end up an Apple/Banana correct?

Just to clarify my original question... if you were to edit the list of items purchased and number the "Car"s (Car1, Car2, Car3)... the randomized result would have the specific value of 'K'?

im re-attaching the file for a better explanation... (ive added multiple Cars and numbered them)
My question was in regards to identifying the serialized Car, rather than just "Car".

So if you Select "Car = "Yes" " from the msgbox do you want to return a random car from those available, or something else ???

i believe my answer would be yes to a "random car from those available". Im just trying to differentiate the Cars purchased in this example.
(so if customer 22 purchase 5 cars, i need the result to be a specific car 1 thru 5)

Try this:-
If you select "Car= Yes" then the returned value will be a single random car from those available for that customer.

Sub MG27Jun27
Dim Rng As Range, Dn As Range, n As Long, Dic As Object, D(0 To 1), Q As Variant
With Sheets("Sheet1")
    Set Rng = .Range("B2", .Range("B" & Rows.Count).End(xlUp))
End With

Set Dic = CreateObject("scripting.dictionary")
For Each Dn In Rng
    If Not Dic.Exists(Dn.Value) Then
        If Dn.Offset(, -1).Value Like "Car*" Then
            D(1) = Dn.Offset(, -1).Value
        Else
            D(0) = Dn.Offset(, -1).Value
        End If
       Dic.Add Dn.Value, Array(D(0), D(1))
    Else
        Q = Dic(Dn.Value)
        If Dn.Offset(, -1).Value Like "Car*" Then
            If InStr(Q(1), Dn.Offset(, -1).Value) = 0 Then
             Q(1) = Q(1) & IIf(Q(1) = "", Dn.Offset(, -1).Value, "," & Dn.Offset(, -1).Value)
           End If
        Else
            If InStr(Q(0), Dn.Offset(, -1).Value) = 0 Then
              Q(0) = Q(0) & IIf(Q(0) = "", Dn.Offset(, -1).Value, "," & Dn.Offset(, -1).Value)
            End If
        End If
       Dic(Dn.Value) = Q
    End If
Next

Dim Num1 As Long, Num2 As Long, P As String, K As Variant, Sp1 As Variant, c As Long, Sp2 As Variant

With Sheets("Sheet2")
.Cells(1, 1) = "Item": .Cells(1, 2) = "Cust #"
c = 1


Dim ans As Long
For Each K In Dic.keys
    [h1] = Dic(K)(1)
    If Not IsEmpty(Dic(K)(1)) Then
         ans = MsgBox("Item = " & K & vbLf & "Car = ""Yes""" & vbLf & "Random item = ""No""", vbYesNo + vbInformation)
            c = c + 1
            .Cells(c, 2) = K
            Sp1 = Split(Dic(K)(0), ",")
            Sp2 = Split(Dic(K)(1), ",")
            Num1 = Application.RandBetween(0, UBound(Sp1))
            Num2 = Application.RandBetween(0, UBound(Sp2))
            .Cells(c, 1) = IIf(ans = vbYes, Sp2(Num2), Sp1(Num1))
    Else
            Sp1 = Split(Dic(K)(0), ",")
            Num1 = Application.RandBetween(0, UBound(Sp1))
            c = c + 1
           .Cells(c, 2) = K
           .Cells(c, 1) = Sp1(Num1)
    End If
Next K
End With
End Sub

Regards Mick

These are all excellent examples to my questions. Thank you again MickG!

You're welcome