Looking for VBA help with randomizer

TsarMarkI

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

Some videos you may like

Excel Facts

Ambidextrous Undo
Undo last command with Ctrl+Z or Alt+Backspace. If you use the Undo icon in the QAT, open the drop-down arrow to undo up to 100 steps.

MickG

MrExcel MVP
Joined
Jan 9, 2008
Messages
14,841
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
 

TsarMarkI

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

MrExcel MVP
Joined
Jan 9, 2008
Messages
14,841
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

MrExcel MVP
Joined
May 26, 2009
Messages
16,951
Office Version
2010
Platform
Windows
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
 

JoeMo

MrExcel MVP
Joined
May 26, 2009
Messages
16,951
Office Version
2010
Platform
Windows
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.
 

Watch MrExcel Video

Forum statistics

Threads
1,102,630
Messages
5,488,004
Members
407,617
Latest member
Samanthad2007

This Week's Hot Topics

  • Timer in VBA - Stop, Start, Pause and Reset
    [CODE=vba][/CODE] Option Explicit Dim CmdStop As Boolean Dim Paused As Boolean Dim Start Dim TimerValue As Date Dim pausedTime As Date Sub...
  • how to updates multiple rows in muliselect listbox
    Hello everyone. I need help with below code. code is only chaning 1st row in mulitiselect list box. i know issue with code...
  • Delete Row from Table
    I am trying to delete a row from a table using VBA using a named range to find what I need to delete. My Range is finding the right cell. In the...
  • Assigning to a variable
    I have a for each block where I want to assign the value in column 5 of the found row to the variable Serv. [CODE=vba] For Each ws In...
  • Way to verify information
    Hi All, I don't know what to call this formula, and therefore can't search. I have a spreadsheet with information I want to reference...
  • Active Cell Address – Inactive Sheet
    How to use VBA to get the cell address of the active cell in an inactive worksheet and then place that cell address in a location on the current...
Top