Looking for VBA help with randomizer

[TsarMarkI]

Good day, all

I'm looking for help creating a macro that will reference a list of unique values, pull 21 of those values to another sheet, and not duplicate those values when I request to pull another 21 values.

Example:
Sheet1 has 250 unique values in column A
Need to pull 21 of these values randomly into Sheet 2, Column A
Need to pull another 21 of these values the next day, clear the old values, but cannot duplicate the previous values on Sheet 2, column A


Right now I'm sort-of accomplishing this by utilizing the below formula:
=INDEX($A$2:$A$250,RANK.EQ(C2,$C$2:$C$250)+COUNTIF($C$2:C2,C2)-1)

With this formula, I've assigned random numbers in column C to the values in column A, and the values are placed into column D. However, this is causing an issue in that it changes every time I update anything on the sheet.

Any help would be greatly appreciated!

 

[MickG]

Try this:-

[COLOR="Navy"]Sub[/COLOR] MG15Aug16
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Omax [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Dic [COLOR="Navy"]As[/COLOR] Object, nRdn [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] cRng [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]With[/COLOR] Sheets("Sheet2")
     [COLOR="Navy"]Set[/COLOR] cRng = .Range("A1", .Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]End[/COLOR] With
 [COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
   
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] cRng
        [COLOR="Navy"]If[/COLOR] Dn <> "" [COLOR="Navy"]Then[/COLOR]
            .Item(Dn.Value) = Empty
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] Dn

    [COLOR="Navy"]With[/COLOR] Sheets("Sheet1")
        [COLOR="Navy"]Set[/COLOR] Rng = .Range("A1", .Range("A" & Rows.Count).End(xlUp))
   [COLOR="Navy"]End[/COLOR] With
    [COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
        Dic.CompareMode = vbTextCompare
            Omax = 21
                Randomize
    [COLOR="Navy"]Do[/COLOR] Until Dic.Count = Omax
        nRdn = Int(Rnd * Rng.Count) + 1
        [COLOR="Navy"]If[/COLOR] Not .exists(nRdn) And Not Dic.exists(nRdn) [COLOR="Navy"]Then[/COLOR]
            Dic(Rng(nRdn)) = Empty
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Loop[/COLOR]

Sheets("Sheet2").Range("A1").Resize(Dic.Count) = Application.Transpose(Dic.Keys)
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[TsarMarkI]

Thanks Mick- it runs well, just appears to have a couple issues:

1. When it pulls the data to Sheet2, it also is pulling in blanks among the 21 values- I need it to not pull any blank values
2. Will this data pull continue to pull unique, non-duplicate values until all values have been shown at least once? I have 299 unique values that I would like to appear at least once, 21 values at a time.

The rest of this pull works brilliantly- thanks for the help!

 

[MickG]

I assume from what you say that column "A" has some blank cells ??

As you list count in column "A" divided by 21 does not return a whole number, its not easy to ensure all numbers are shown in the minimum number of clicks. so are you happy to keep Clicking the code until all the numbers are used.

Using some test code, I have found this takes approx 70 clicks

 

[JoeMo]

Here's another macro for you to consider.

Sub PullHowManyRand()
'Assumes Sheet2 exists with a header in A1. output will start in A2
Const HowMany As Long = 21
Dim R1 As Range, V1 As Variant, R2 As Range, V2 As Variant, Vout As Variant
Dim Pick As Long, M As Variant, Ct As Long, d As Object
Set R1 = Sheets("Sheet1").Range("A2:A" & Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row)
V1 = R1.Value
If Application.CountA(Sheets("Sheet2").Columns("A")) > 1 Then
    Set R2 = Sheets("Sheet2").Range("A2:A" & Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row)
    V2 = R2.Value
End If
ReDim Vout(1 To UBound(V1, 1), 1 To 1)
Set d = CreateObject("Scripting.dictionary")
d.RemoveAll
Do
    Pick = Application.RandBetween(LBound(V1, 1), UBound(V1, 1))
    If Not d.exists(Pick) Then
        d.Add Pick, d.Count + 1
        If Not R2 Is Nothing Then
            M = Application.Match(V1(Pick, 1), V2, 0)
            If IsError(M) Then
                Ct = Ct + 1
                Vout(Ct, 1) = V1(Pick, 1)
            End If
        Else
            Ct = d.Count
            Vout(Ct, 1) = V1(Pick, 1)
        End If
    End If
Loop While Ct < HowMany
Application.ScreenUpdating = False
If Not R2 Is Nothing Then
    With R2
        .ClearContents
        .Value = Vout
    End With
Else
    Sheets("Sheet2").Range("A2:A" & d.Count + 1).Value = Vout
End If
Application.ScreenUpdating = True
End Sub

 

[JoeMo]

As a follow-up to post #5 : I interpreted this part of your OP: "and not duplicate those values when I request to pull another 21 values." to mean, in the current run, you don't want any duplicates, and you don't want to duplicate any of the values pulled in the previous run. The code I posted will allow reuse of values previously pulled from Sheet1 subject to the exclusion of values used in the previous run.