Looking for VBA help with randomizer

TsarMarkI

New Member
Joined
Aug 14, 2019
Messages
20
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!
 

Excel Facts

Copy formula down without changing references
If you have =SUM(F2:F49) in F50; type Alt+' in F51 to copy =SUM(F2:F49) to F51, leaving the formula in edit mode. Change SUM to COUNT.
Try this:-
Code:
[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
 
Upvote 0
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!
 
Upvote 0
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
 
Upvote 0
Here's another macro for you to consider.
Code:
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
 
Upvote 0
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.
 
Upvote 0

Forum statistics

Threads
1,213,561
Messages
6,114,312
Members
448,564
Latest member
ED38

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
Back
Top