Looking for VBA help with randomizer
Results 1 to 6 of 6

Thread: Looking for VBA help with randomizer
Thanks Thanks: 0 Likes Likes: 0

  1. #1
    New Member
    Join Date
    Aug 2019
    Posts
    7
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Looking for VBA help with randomizer

    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!

  2. #2
    MrExcel MVP
    Join Date
    Jan 2008
    Posts
    14,834
    Post Thanks / Like
    Mentioned
    26 Post(s)
    Tagged
    12 Thread(s)

    Default Re: Looking for VBA help with randomizer

    Try this:-
    Code:
    Sub MG15Aug16
    Dim Rng As Range, Dn As Range, n As Long, Omax As Long
    Dim Dic As Object, nRdn As Long, cRng As Range
    With Sheets("Sheet2")
         Set cRng = .Range("A1", .Range("A" & Rows.Count).End(xlUp))
    End With
     With CreateObject("scripting.dictionary")
       
        For Each Dn In cRng
            If Dn <> "" Then
                .Item(Dn.Value) = Empty
            End If
        Next Dn
    
        With Sheets("Sheet1")
            Set Rng = .Range("A1", .Range("A" & Rows.Count).End(xlUp))
       End With
        Set Dic = CreateObject("scripting.dictionary")
            Dic.CompareMode = vbTextCompare
                Omax = 21
                    Randomize
        Do Until Dic.Count = Omax
            nRdn = Int(Rnd * Rng.Count) + 1
            If Not .exists(nRdn) And Not Dic.exists(nRdn) Then
                Dic(Rng(nRdn)) = Empty
            End If
        Loop
    
    Sheets("Sheet2").Range("A1").Resize(Dic.Count) = Application.Transpose(Dic.Keys)
    End With
    End Sub
    Regards Mick

  3. #3
    New Member
    Join Date
    Aug 2019
    Posts
    7
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Looking for VBA help with randomizer

    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!

  4. #4
    MrExcel MVP
    Join Date
    Jan 2008
    Posts
    14,834
    Post Thanks / Like
    Mentioned
    26 Post(s)
    Tagged
    12 Thread(s)

    Default Re: Looking for VBA help with randomizer

    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

  5. #5
    MrExcel MVP
    Join Date
    May 2009
    Posts
    16,368
    Post Thanks / Like
    Mentioned
    36 Post(s)
    Tagged
    8 Thread(s)

    Default Re: Looking for VBA help with randomizer

    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
    Joe

    When I was a young man I knew everything. Now that I'm older, I realize I know very little, and what I do know, I tend to forget!

  6. #6
    MrExcel MVP
    Join Date
    May 2009
    Posts
    16,368
    Post Thanks / Like
    Mentioned
    36 Post(s)
    Tagged
    8 Thread(s)

    Default Re: Looking for VBA help with randomizer

    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.
    Joe

    When I was a young man I knew everything. Now that I'm older, I realize I know very little, and what I do know, I tend to forget!

Some videos you may like

User Tag List

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •