I need to set ranges for Unique values, then from those ranges pick random cells...

Code modified to give results as specified:-

Sub MG21May35
Dim Rng         As Range
Dim Dn          As Range
Dim Dic1        As Object
Dim Dic2        As Object
Dim oMax        As Long
Dim nRdn        As Long
Dim k           As Variant
Dim c As Long
c = 1
Set Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
Set Dic1 = CreateObject("scripting.dictionary")
Dic1.CompareMode = vbTextCompare
For Each Dn In Rng
    If Not Dic1.exists(Dn.Value) Then
        Dic1.Add Dn.Value, Dn
    Else
        Set Dic1.Item(Dn.Value) = Union(Dic1.Item(Dn.Value), Dn)
End If
Next
 For Each k In Dic1.keys
    If Dic1.Item(k).Count <= 10 Then
       Cells(c, 4) = k
       Cells(c + 1, 4).Resize(Dic1.Item(k).Count) = Dic1.Item(k).Offset(, 2).Value
    Else
        Set Dic2 = CreateObject("scripting.dictionary")
            Dic2.CompareMode = vbTextCompare
                oMax = 10
                    Randomize
                Do Until Dic2.Count = oMax
                    nRdn = Int(Rnd * Dic1.Item(k).Count + 1)
                    If Not Dic2.exists(Dic1.Item(k)(nRdn).Offset(, 2).Value) Then
                        Dic2.Add Dic1.Item(k)(nRdn).Offset(, 2).Value, Nothing
                    End If
                Loop
                Cells(c, 4) = k
                Cells(c + 1, 4).Resize(10) = Application.Transpose(Dic2.keys)
                c = c + 11
    End If
Next k
End Sub

Regards Mick