How to make excel random selector not choose the same thing twice?

Question

I am using some code I used from another source and tweaked it to my needs. The only thing, I am now wondering if I can make it to where it will not select the same row twice? E6's value will always be between 5 and 25, and this will pull from 500+ rows. I just want to ensure that the data pulled is not the same. This is for auditing purposes for another team with little to no excel experience. That is why I am making this a macro.

I have googled a few things to try but I guess I do not know how to implement it correctly or it simply does not work.

Option Explicit
Option Base 1

Sub Random_Sel()

Dim LastRow As Long
Dim NbRows As Long
Dim RowList()
Dim I As Long, J As Long, K As Long
Dim RowNb As Long
    Sheets("DATA").Activate
    LastRow = Range("A" & Rows.Count).End(xlUp).Row
    NbRows = Sheets("MACRO").Range("E6").Value
    ReDim RowList(1 To NbRows)
    K = 1
    For I = 1 To NbRows
        RowNb = Rnd() * LastRow
        For J = 1 To K
            If (RowList(J) = RowNb) Then GoTo NextStep
        Next J
        RowList(K) = RowNb
        Rows(RowNb).Copy Destination:=Sheets("Sheet2").Cells(K, "A")
        K = K + 1
NextStep:
    Next I
End Sub

Expected outcome will be to have the data on Sheet2 not be duplicated. Column B is where my unique identifier will lie to determine if it is a duplicate.

I would have a hidden sheet storing the rows already selected and ignore them on the selection with an If statement. Also, if you have an identifier. Store the column B values on sheet2 on a dictionary and check them before copying. — Damian, May 09 '19 at 13:14
Without reading the code, how about using `.Find` to find the newly generated value in the column? If this returns nothing, it's a unique value — Tim Stack, May 09 '19 at 13:22
Also, reading your code now, make sure you specify both the workbook and -sheet for each range object. I recommend using a `With` statement. — Tim Stack, May 09 '19 at 13:22
@TimStack - I will definitely specify the workbooks and worksheets for my end goal. Sheet2's info will eventually end up on its own workbook auto saving to a specified folder for this team to grab and audit from. — Mass Nerderer, May 09 '19 at 13:51

score 2 · Answer 1 · answered May 09 '19 at 13:33

You'll need to keep track whether the row was already checked.

First though, we'll need to create a function to check, whether the element is in array

courtesy of @Brad from Check if a value is in an array or not with Excel VBA

Public Function IsInArray(number As Integer, arr As Variant) As Boolean
    Dim i
    For i = LBound(arr) To UBound(arr)
        If arr(i) = number Then
            IsInArray = True
            Exit Function
        End If
    Next i
    IsInArray = False

End Function

So before your loop, you'll need to declare an array.

Dim checkedrows() As Integer
Dim counter as Integer: counter = 0 ' to keep track of Re-Dim

and inside the loop, presuming the value you want to check is inside RowNb

If Not IsInArray(RowNb, checkedrows) Then ' was not checked yet
   ' do something (your code)... and then:
   counter = counter + 1
   ReDim Preserve checkedrows(counter)
   checkedrows(counter) = RowNb ' adds the row to the  checkedrows array
End If

score 0 · Answer 2 · answered May 09 '19 at 14:17

@Rawrplus So does it need to look like this? When I compile this way, I get a ByRef Argument type mismatch error.

Option Explicit
Option Base 1
Public Function IsInArray(number As Integer, arr As Variant) As Boolean
    Dim i
    For i = LBound(arr) To UBound(arr)
        If arr(i) = number Then
            IsInArray = True
            Exit Function
        End If
    Next i
    IsInArray = False

End Function
Sub Random_Sel()

Dim checkedrows() As Integer
Dim counter As Integer: counter = 0
Dim LastRow As Long
Dim NbRows As Long
Dim RowList()
Dim i As Long, J As Long, K As Long
Dim RowNb As Long

If Not IsInArray(RowNb, checkedrows) Then
    Sheets("DATA").Activate
    LastRow = Range("A" & Rows.Count).End(xlUp).Row
    NbRows = Sheets("MACRO").Range("E6").Value
    ReDim RowList(1 To NbRows)
    K = 1
    For i = 1 To NbRows
        RowNb = Rnd() * LastRow
        For J = 1 To K
            If (RowList(J) = RowNb) Then GoTo NextStep
        Next J
        RowList(K) = RowNb
        Rows(RowNb).Copy Destination:=Sheets("Sheet2").Cells(K, "A")
        K = K + 1
NextStep:
    Next i
   counter = counter + 1
   ReDim Preserve checkedrows(counter)
   checkedrows(counter) = RowNb
End If
End Sub

JosephC · Answer 3 · 2019-05-09T20:30:26.253

0

Here's a different way to build a list of unique random numbers. It's based off the fact that a collection's key has to be unique.

It will build a list NumPicks long, of numbers in between MinNum and MaxNum If it tries to add a number that is already in the list it will send an error, and we resume next.

Sub Test()
    Dim oNumbers As Collection
    'Test picking 10 numbers between 6 and 16
    Set oNumbers = RandomList(6, 16, 10)
End Sub

Public Function RandomList(ByVal MinNum As Long, ByVal MaxNum As Long, ByVal NumPicks As Long) As Collection
    Dim oRet As New Collection

    If MaxNum - MinNum < NumPicks Then
        MsgBox ("Not enough items to have unique picks")
        Exit Function
    End If

    Dim oRandom As Long
    Do Until oRet.Count = NumPicks
        On Error Resume Next
        oRandom = Int((MaxNum - MinNum + 1) * Rnd + MinNum)
        oRet.Add oRandom, CStr(oRandom)
        On Error GoTo 0
    Loop

    Set RandomList = oRet
End Function

edited May 09 '19 at 20:30

answered May 09 '19 at 16:48

JosephC

917
4
12

So I am wishing to have the user input a number between 5 and 25 into a cell, and the macro pull that number of random rows. Is there a way to implement that into this? – Mass Nerderer May 09 '19 at 17:17
If your data starts on row 1: `Set oNumbers = RandomList(1, Range("A" & Rows.Count).End(xlUp).Row, Sheets("MACRO").Range("E6").Value)` if you want to use your variables: `Set oNumbers = RandomList(1, LastRow, NbRows)` – JosephC May 09 '19 at 17:35
I would like to learn how this works. It is small code but looks efficient. When this is ran, where exactly does that data get stored? And how do I call it to a worksheet? I received an error on `Do Until Ret.Count = NumPicks`, so I changed it to `oRet.Count`. That seemed to make the error go away, but I do not see where my data is generated? – Mass Nerderer May 09 '19 at 19:01
Sorry about the Ret.Count.. That'll teach me to not include Option Explicit even when writing some quick code. :p Edited post to make the change. – JosephC May 09 '19 at 20:30
Your numbers are in the declared collection, in my test it's in `oNumbers`. The data is generated by creating a random number and then adding it into a collection as both the value and the key. Collections key must be unique, so if you try to add two keys that are the same into the same collection it will throw an error. This code ignores that error, skips the add, and generates a new number. It loops until the number of items in the collection equal the number of items you've requested with the `NumPicks` parameter. – JosephC May 09 '19 at 20:30

tigeravatar · Accepted Answer · 2019-05-09T18:33:07.987

Something like this should work for you:

Sub tgr()

    Dim wb As Workbook
    Dim wsData As Worksheet
    Dim wsMacro As Worksheet
    Dim wsDest As Worksheet

    Set wb = ThisWorkbook
    Set wsData = wb.Worksheets("DATA")
    Set wsMacro = wb.Worksheets("MACRO")
    Set wsDest = wb.Worksheets("Sheet2")

    Dim lNumResults As Long
    lNumResults = wsMacro.Range("E6").Value
    If lNumResults <= 0 Then
        MsgBox "Number of Randomly Selected results must be greater than 0", , "Error"
        Exit Sub
    End If

    Dim aResults() As Variant
    ReDim aResults(1 To lNumResults, 1 To 1)

    Dim aData As Variant
    With wsData.Range("A1", wsData.Cells(wsData.Rows.Count, "A").End(xlUp))
        If .Cells.Count = 1 Then
            ReDim aData(1 To 1)
            aData(1) = .Value
        Else
            aData = Application.Transpose(.Value)
        End If
    End With

    Dim sDelim As String
    sDelim = Chr(1)

    Dim sTemp As String
    Dim lRandom As Long
    Dim ixResult As Long
    Dim i As Long

    ixResult = 0
    For i = 1 To UBound(aResults, 1)
        Randomize
        lRandom = Int(Rnd() * UBound(aData)) + IIf(i = 1, 1, 0)
        ixResult = ixResult + 1
        aResults(ixResult, 1) = aData(lRandom)
        sTemp = Join(aData, sDelim)
        sTemp = Replace(sDelim & sTemp & sDelim, sDelim & aResults(i, 1) & sDelim, sDelim, , , vbTextCompare)
        If Len(sTemp) > Len(sDelim) Then
            sTemp = Mid(sTemp, Len(sDelim) + 1, Len(sTemp) - Len(sDelim) * 2)
            aData = Split(sTemp, sDelim)
        Else
            Exit For
        End If
    Next i

    wsDest.Columns("A").ClearContents
    wsDest.Range("A1").Resize(ixResult).Value = aResults

End Sub

EDIT: This method will copy the entire row of each randomly selected value from column A of the "DATA" sheet:

Sub tgr()

    Dim wb As Workbook
    Dim wsData As Worksheet
    Dim wsMacro As Worksheet
    Dim wsDest As Worksheet

    Set wb = ThisWorkbook
    Set wsData = wb.Worksheets("DATA")
    Set wsMacro = wb.Worksheets("MACRO")
    Set wsDest = wb.Worksheets("Sheet2")

    Dim lNumResults As Long
    lNumResults = wsMacro.Range("E6").Value
    If lNumResults <= 0 Then
        MsgBox "Number of Randomly Selected results must be greater than 0", , "Error"
        Exit Sub
    End If

    Dim aData As Variant
    Dim i As Long
    With wsData.Range("A1", wsData.Cells(wsData.Rows.Count, "A").End(xlUp))
        If .Cells.Count = 1 Then
            ReDim aData(1 To 1)
            aData(1) = .Address
        Else
            ReDim aData(1 To .Cells.Count)
            Dim DataCell As Range
            i = 0
            For Each DataCell In .Cells
                i = i + 1
                aData(i) = DataCell.Address
            Next DataCell
        End If
    End With

    Dim sDelim As String
    sDelim = Chr(1)

    Dim rCopy As Range
    Dim sTemp As String
    Dim lRandom As Long

    For i = 1 To lNumResults
        Randomize
        lRandom = Int(Rnd() * UBound(aData)) + IIf(i = 1, 1, 0)
        If Not rCopy Is Nothing Then
            Set rCopy = Union(rCopy, wsData.Range(aData(lRandom)))
        Else
            Set rCopy = wsData.Range(aData(lRandom))
        End If
        sTemp = Join(aData, sDelim)
        sTemp = Replace(sDelim & sTemp & sDelim, sDelim & aData(lRandom) & sDelim, sDelim, , , vbTextCompare)
        If Len(sTemp) > Len(sDelim) Then
            sTemp = Mid(sTemp, Len(sDelim) + 1, Len(sTemp) - Len(sDelim) * 2)
            aData = Split(sTemp, sDelim)
        Else
            Exit For
        End If
    Next i

    wsDest.Cells.Clear
    If Not rCopy Is Nothing Then rCopy.EntireRow.Copy wsDest.Range("A1")

End Sub

I am encountering a problem. And my beginner brain cannot find wherein lies the issue. If E6's Value is greater than 13 - it stops at 13/14 lines and will not provide any more data. Secondly, is there a way to copy the whole row? What line of code would I need to amend to make that happen? — Mass Nerderer, May 09 '19 at 18:19
@MassNerderer The only way I can reproduce the issue is if you "DATA" sheet only has 13 or 14 values to choose from. I'll put in an edit to this answer to include a way for getting the whole row. — tigeravatar, May 09 '19 at 18:27
@MassNerderer See updated answer, there is now an edit showing a second version of the code for copying the whole row. — tigeravatar, May 09 '19 at 18:33
This works wonderfully. I appreciate your assistance. This has been a great learning opp for me, and I really cannot thank you enough. I am now going to go through your code to see exactly how everything works. Thanks! Cheers. — Mass Nerderer, May 09 '19 at 18:59

How to make excel random selector not choose the same thing twice?

4 Answers4