none
Excel VBA RandBetween without replication RRS feed

  • Question

  • Hello All!

    Hoping someone here can help me. I am attempting to write a macro that is triggered on a button click event. The macro has been executing perfectly except for one issue that continues to occur at random interval (ironic huh!).

    Here is the scenario:

    User has a population dataset that will be pasted into worksheet "Population". Colum A is going to be used for indexing purposes so the data set will be pasted into B2.  Objective is user will click the button and a sample which WILL NOT include duplicates will be selected using RandBetween function from the "Population" sheet and pasted into another sheet.

    Here are the issues that I am having:

    1. I keep getting a handful of duplicate rows in the sample from the Population. 

    2. I need to add in a block of code that will define the row count for a table on another sheet based on the pCount variable. Would that be done with something like Sheets("Sheet2").Rows.Count = pCount ?

    3. I need to write a block of code that will search columns to determine if the values meet these two conditions.

    • Date is Before X
    • Value is <= X

    If both conditions are met the entire corresponding row should be deleted and not included in the sample.

    New to VBA so any help on how to approach this would be greatly appreciated.

    Thanks in advance for the help.

    Sub generateSample()
    
    Dim Population As Range
    Dim lastRow As Long, firstRow As Long
    Dim SampleSize As Long
    Dim Unique As Boolean
    Dim i As Long, a As Long, n As Long
    Dim pCount As Long
    pCount = Sheets("Sample Variables").Range("B4")
    
    Sheets("Sheet2").Range("SampleData").ClearContents
    
    
    Set Population = Sheets("Population").Range("A:A")
    SampleSize = Sheets("Sample Variables").Range("B1")
    
    
    Set r = Population
    lastRow = pCount
    firstRow = r.Range("A2")
    
        For i = 1 To SampleSize
         Do
         
         Unique = True
         n = Application.WorksheetFunction.RandBetween(firstRow, lastRow)
         
           For a = 1 To i - 1
                If Cells(a, 1) = n Then
                Unique = False
                Exit For
                End If
            Next a
            
            If Unique = True Then
            Exit Do
            End If
            
        Loop
        
        Sheets("Sheet2").Select
        Cells(i + 6, 1) = n
        Cells(i + 6, 3) = Application.Sheets("Population").Range("B" + CStr(n))
        Cells(i + 6, 6) = Application.Sheets("Population").Range("C" + CStr(n))
        Cells(i + 6, 7) = Application.Sheets("Population").Range("M" + CStr(n))
        Cells(i + 6, 8) = Application.Sheets("Population").Range("O" + CStr(n))
        Cells(i + 6, 10) = Application.Sheets("Population").Range("F" + CStr(n))
        'Cells(i + 6, 11) = Application.Sheets("Population").Range("B" + CStr(n))
        'Cells(i + 6, 12) = Application.Sheets("Population").Range("B" + CStr(n))
        Cells(i + 6, 13) = Application.Sheets("Population").Range("R" + CStr(n))
        Cells(i + 6, 14) = Application.Sheets("Population").Range("X" + CStr(n))
        Cells(i + 6, 15) = Application.Sheets("Population").Range("BI" + CStr(n))
        'Cells(i + 6, 17) = Application.Sheets("Population").Range("B" + CStr(n))
    
        Next i
    
    Sheets("Sheet2").Select
    
    
    End Sub
     



    • Edited by CodeGuy2017 Wednesday, February 8, 2017 6:21 PM
    Wednesday, February 8, 2017 5:55 PM

Answers

  • CG,
    re: Code is fighting me

    Try replacing the the single code line in your code...
      "N = Application.WorksheetFunction.RandBetween(firstrow, lastrow)"
    With...
    '---
     Do
     N = Application.WorksheetFunction.RandBetween(firstrow, lastrow)
      If arrCheck(N) = 0 Then
         arrCheck(N) = N
         Exit Do
      End If
     Loop
    '---
    Also declare
      Dim arrCheck() As Long

    After firstRow and lastRow have values established, insert this line...
      ReDim arrCheck(firstrow To lastrow)
    '---

    [Edit] added comments below...
    It appears you need to replace your Do/Loop code with mine.
    Also, you need to add the single word  Randomize  before the start of your For/Next loop.
    '---
    Jim Cone
    Portland, Oregon USA
    https://goo.gl/IUQUN2 (Dropbox)
    (free & commercial excel add-ins & workbooks)


    • Edited by James Cone Friday, February 10, 2017 7:11 PM
    • Marked as answer by CodeGuy2017 Friday, February 10, 2017 7:13 PM
    Friday, February 10, 2017 7:04 PM

All replies

  • CG,

    Re: unique random numbers

    'You should be able to adapt the code below to your needs.
    'Note: numeric array elements are initialized to 0
    'Not practical for very large arrays.
    'Generates five random numbers between 1 and 20 with no duplicates.
    'Concept stolen from Tom Ogilvy.
    'Jim Cone - Portland, Oregon USA - May 2006

    '---
    Sub GetThem()
     Dim arrCheck(1 To 20) As Long
     Dim arrList(1 To 5) As Long
     Dim j As Long
     Dim N As Long
     
     j = 1
     Randomize
     Do While j < 6
      'Get a random number
       N = Int(Rnd * 20 + 1)
      'If number unique then add to arrList.
       If arrCheck(N) = 0 Then
          arrList(j) = N
          arrCheck(N) = N
          j = j + 1
       End If
     Loop
     Range("B5:F5").Value = arrList()
     End Sub

    '---
    Jim Cone
    Portland, Oregon USA
    https://goo.gl/IUQUN2 (Dropbox)
    (free & commercial excel add-ins & workbooks)
    Wednesday, February 8, 2017 11:08 PM
  • Jim, Thanks for the reply but unfortunately that method will not work for me. The population and number of samples being pulled is constantly changing and I kept getting an error that I had to use a constant when I was defining the population in the array.
    Friday, February 10, 2017 10:37 AM
  • CG,
    re: Code is fighting me

    Try replacing the the single code line in your code...
      "N = Application.WorksheetFunction.RandBetween(firstrow, lastrow)"
    With...
    '---
     Do
     N = Application.WorksheetFunction.RandBetween(firstrow, lastrow)
      If arrCheck(N) = 0 Then
         arrCheck(N) = N
         Exit Do
      End If
     Loop
    '---
    Also declare
      Dim arrCheck() As Long

    After firstRow and lastRow have values established, insert this line...
      ReDim arrCheck(firstrow To lastrow)
    '---

    [Edit] added comments below...
    It appears you need to replace your Do/Loop code with mine.
    Also, you need to add the single word  Randomize  before the start of your For/Next loop.
    '---
    Jim Cone
    Portland, Oregon USA
    https://goo.gl/IUQUN2 (Dropbox)
    (free & commercial excel add-ins & workbooks)


    • Edited by James Cone Friday, February 10, 2017 7:11 PM
    • Marked as answer by CodeGuy2017 Friday, February 10, 2017 7:13 PM
    Friday, February 10, 2017 7:04 PM
  • JC,

    That did the trick thank you so much!

    Friday, February 10, 2017 7:19 PM