VBA for random selection of numbers from a column with several conditions

dchapman17

New Member
Joined
May 18, 2021
Messages
8
Good morning.

Moderator edit: Refer to: This thread

Apologies for hijacking a thread, however the original posters requirement is very similar to mine.

I have taken the VB code and tried to manipulate it to provide the information that I require, however I've not had any success. I can get the Macro to run for the code posted in #11 but when I try to reduce the number of searched rows and change the number of A, B and C results provided then I encounter a problem.

I have 538 rows of data consisting of 205 category A's (rows 2 to 206), 125 category B's (rows 207 to 331) and 208 category C's (rows 332 to 539).

I would like to randomly select 10 x A, 3 x B and 1 x C on a daily basis when I manually run the Macro. If at all possible, the A's need to reappear every 21 days, the B's need to appear every 42 days and the C's once every 253 days.

I would appreciate any help that can be offered. Thank you in advance.
 
Last edited by a moderator:

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
52,372
Office Version
  1. 365
Platform
  1. Windows
Option 1 will be fine. As long as each value appears once within the 20 or 21 day period then it's fine for certain values to appear twice.
I'm not sure that you have understood what I was trying to say, but this is what I had in mind for option 1.
I am using column D (could be another column) to record when a particular item was chosen to help with the "not to be chosen again within a X day period"
It also wasn't clear about whether each set of results is to be kept. For the moment, this code does (at least so you can check if it is behaving as you want) by pushing everything from column K on to the right and putting the new results in column K.

VBA Code:
Sub MakeSamplesEachDay_v01()
  Dim dA As Object, dB As Object, dC As Object
  Dim Aorig As Variant, Borig As Variant, Corig As Variant, Apicked As Variant, Bpicked As Variant, Cpicked As Variant
  Dim i As Long, j As Long, idx As Long
  Dim Tday As Date
  
  Const NoRepeatA As Long = 21
  Const NoRepeatB As Long = 42
  Const NoRepeatC As Long = 208
  Const Apicks As Long = 10
  Const Bpicks As Long = 3
  Const CPicks As Long = 1
  Const ResultCol As String = "K"
  
  Randomize
  Tday = Date
  ReDim Apicked(1 To Apicks)
  ReDim Bpicked(1 To Bpicks)
  ReDim Cpicked(1 To CPicks)
  Set dA = CreateObject("Scripting.Dictionary")
  Set dB = CreateObject("Scripting.Dictionary")
  Set dC = CreateObject("Scripting.Dictionary")
  
  Application.ScreenUpdating = False
  ActiveSheet.AutoFilterMode = False
  With Range("B1:D" & Range("B" & Rows.Count).End(xlUp).Row)
    .AutoFilter Field:=2, Criteria1:="A"
    Aorig = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlVisible).Value
    .AutoFilter Field:=2, Criteria1:="B"
    Borig = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlVisible).Value
    .AutoFilter Field:=2, Criteria1:="C"
    Corig = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlVisible).Value
    .AutoFilter Field:=2
  End With
  Application.ScreenUpdating = True
  
  'Choose A's from remaining dictionary items
  'If at any time a dictionary gets emptied, then re-load it with the next date-relevant values
  For j = 1 To Apicks
    If dA.Count = 0 Then ReloadDic dA, Aorig, NoRepeatA, Apicked
    idx = Int(Rnd() * dA.Count)
    Apicked(j) = dA.keys()(idx)
    Aorig(dA(Apicked(j)), 3) = Tday
    dA.Remove Apicked(j)
  Next j
  
  'Choose B's ....
  For j = 1 To Bpicks
    If dB.Count = 0 Then ReloadDic dB, Borig, NoRepeatB, Bpicked
    idx = Int(Rnd() * dB.Count)
    Bpicked(j) = dB.keys()(idx)
    Borig(dB(Bpicked(j)), 3) = Tday
    dB.Remove Bpicked(j)
  Next j
    
  'Choose C's ....
  For j = 1 To CPicks
    If dC.Count = 0 Then ReloadDic dC, Corig, NoRepeatC, Cpicked
    idx = Int(Rnd() * dC.Count)
    Cpicked(j) = dC.keys()(idx)
    Corig(dC(Cpicked(j)), 3) = Tday
    dC.Remove Cpicked(j)
  Next j
  
  'Output results & update Last Checked date
  Application.ScreenUpdating = False
  Columns(ResultCol).Insert
  Cells(1, ResultCol).Value = Date
  Cells(Rows.Count, ResultCol).End(xlUp).Offset(1).Resize(Apicks).Value = Application.Transpose(Apicked)
  Cells(Rows.Count, ResultCol).End(xlUp).Offset(1).Resize(Bpicks).Value = Application.Transpose(Bpicked)
  Cells(Rows.Count, ResultCol).End(xlUp).Offset(1).Resize(CPicks).Value = Application.Transpose(Cpicked)
  Range("B2:D2").Resize(UBound(Aorig)).Value = Aorig
  Range("B2:D2").Offset(UBound(Aorig)).Resize(UBound(Borig)).Value = Borig
  Application.ScreenUpdating = True
End Sub

Sub ReloadDic(d As Object, aData As Variant, WaitPeriod As Long, AlreadyUsed As Variant)
  Dim r As Long, k As Long, NumUsed As Long
  
  k = 0
  NumUsed = UBound(Filter(Split("|" & Join(AlreadyUsed, "|#|") & "|", "#"), "||", False)) + 1
  Do While d.Count = 0 And k <= WaitPeriod
    For r = 1 To UBound(aData)
      If aData(r, 3) <= Date - WaitPeriod + k Then d(aData(r, 1)) = r
    Next r
    For r = 1 To NumUsed
      If d.exists(AlreadyUsed(r)) Then d.Remove AlreadyUsed(r)
    Next r
    k = k + 1
  Loop
End Sub

Here is part of my test sheet after 3 day's runs.
My initial comments refer to the fact that, for example, the green values below are likely to turn up in the same group or very near each other again when all the other 'A' values have been chosen.

dchapman17_1.xlsm
ABCDEJKLM
1PartDescCatLast Checked19/05/202118/05/202117/05/2021
21A_Dummy 1AA_Dummy 69A_Dummy 146A_Dummy 186
32A_Dummy 2AA_Dummy 73A_Dummy 76A_Dummy 200
43A_Dummy 3AA_Dummy 119A_Dummy 43A_Dummy 35
54A_Dummy 4AA_Dummy 95A_Dummy 50A_Dummy 162
65A_Dummy 5A18/05/2021A_Dummy 165A_Dummy 145A_Dummy 194
76A_Dummy 6AA_Dummy 189A_Dummy 5A_Dummy 75
87A_Dummy 7AA_Dummy 71A_Dummy 128A_Dummy 129
98A_Dummy 8AA_Dummy 16A_Dummy 27A_Dummy 137
109A_Dummy 9AA_Dummy 106A_Dummy 164A_Dummy 148
1110A_Dummy 10AA_Dummy 61A_Dummy 170A_Dummy 205
1211A_Dummy 11AB_Dummy 97B_Dummy 45B_Dummy 11
1312A_Dummy 12AB_Dummy 52B_Dummy 109B_Dummy 75
1413A_Dummy 13AB_Dummy 14B_Dummy 34B_Dummy 62
1514A_Dummy 14AC_Dummy 15C_Dummy 140C_Dummy 92
1615A_Dummy 15A
1716A_Dummy 16A19/05/2021
1817A_Dummy 17A
1918A_Dummy 18A
2019A_Dummy 19A
2120A_Dummy 20A
2221A_Dummy 21A
2322A_Dummy 22A
2423A_Dummy 23A
2524A_Dummy 24A
2625A_Dummy 25A
2726A_Dummy 26A
2827A_Dummy 27A18/05/2021
2928A_Dummy 28A
3029A_Dummy 29A
3130A_Dummy 30A
3231A_Dummy 31A
3332A_Dummy 32A
3433A_Dummy 33A
3534A_Dummy 34A
3635A_Dummy 35A17/05/2021
Sheet1
 

Excel Facts

Format cells as time
Select range and press Ctrl+Shift+2 to format cells as time. (Shift 2 is the @ sign).

dchapman17

New Member
Joined
May 18, 2021
Messages
8
Thank you Peter, this is brilliant.

I just have a final questions if you wouldn't mind offering your guidance::

If I wanted the code to select the data from column A rather than column B (for column K), how would I change this? I've played about with this but could not get the macro to work:

With Range("B1:D" & Range("B" & Rows.Count).End(xlUp).Row)

Thank you so much for your help.
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
52,372
Office Version
  1. 365
Platform
  1. Windows
If I wanted the code to select the data from column A rather than column B (for column K), how would I change this?

There are a few changes required. I think I have addressed them all. Replace both previous codes with these and test again.

VBA Code:
Sub MakeSamplesEachDay_v02()
  Dim dA As Object, dB As Object, dC As Object
  Dim Aorig As Variant, Borig As Variant, Corig As Variant, Apicked As Variant, Bpicked As Variant, Cpicked As Variant
  Dim i As Long, j As Long, idx As Long
  Dim Tday As Date
  
  Const NoRepeatA As Long = 21
  Const NoRepeatB As Long = 42
  Const NoRepeatC As Long = 208
  Const Apicks As Long = 10
  Const Bpicks As Long = 3
  Const CPicks As Long = 1
  Const ResultCol As String = "K"
  
  Randomize
  Tday = Date
  ReDim Apicked(1 To Apicks)
  ReDim Bpicked(1 To Bpicks)
  ReDim Cpicked(1 To CPicks)
  Set dA = CreateObject("Scripting.Dictionary")
  Set dB = CreateObject("Scripting.Dictionary")
  Set dC = CreateObject("Scripting.Dictionary")
  
  Application.ScreenUpdating = False
  ActiveSheet.AutoFilterMode = False
  With Range("A1:D" & Range("B" & Rows.Count).End(xlUp).Row)
    .AutoFilter Field:=3, Criteria1:="A"
    Aorig = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlVisible).Value
    .AutoFilter Field:=3, Criteria1:="B"
    Borig = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlVisible).Value
    .AutoFilter Field:=3, Criteria1:="C"
    Corig = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlVisible).Value
    .AutoFilter Field:=3
  End With
  Application.ScreenUpdating = True
  
  'Choose A's from remaining dictionary items
  'If at any time a dictionary gets emptied, then re-load it with the next date-relevant values
  For j = 1 To Apicks
    If dA.Count = 0 Then ReloadDic dA, Aorig, NoRepeatA, Apicked
    idx = Int(Rnd() * dA.Count)
    Apicked(j) = dA.keys()(idx)
    Aorig(dA(Apicked(j)), 4) = Tday
    dA.Remove Apicked(j)
  Next j
  
  'Choose B's ....
  For j = 1 To Bpicks
    If dB.Count = 0 Then ReloadDic dB, Borig, NoRepeatB, Bpicked
    idx = Int(Rnd() * dB.Count)
    Bpicked(j) = dB.keys()(idx)
    Borig(dB(Bpicked(j)), 4) = Tday
    dB.Remove Bpicked(j)
  Next j
    
  'Choose C's ....
  For j = 1 To CPicks
    If dC.Count = 0 Then ReloadDic dC, Corig, NoRepeatC, Cpicked
    idx = Int(Rnd() * dC.Count)
    Cpicked(j) = dC.keys()(idx)
    Corig(dC(Cpicked(j)), 4) = Tday
    dC.Remove Cpicked(j)
  Next j
  
  'Output results & update Last Checked date
  Application.ScreenUpdating = False
  Columns(ResultCol).Insert
  Cells(1, ResultCol).Value = Date
  Cells(Rows.Count, ResultCol).End(xlUp).Offset(1).Resize(Apicks).Value = Application.Transpose(Apicked)
  Cells(Rows.Count, ResultCol).End(xlUp).Offset(1).Resize(Bpicks).Value = Application.Transpose(Bpicked)
  Cells(Rows.Count, ResultCol).End(xlUp).Offset(1).Resize(CPicks).Value = Application.Transpose(Cpicked)
  Range("A2:D2").Resize(UBound(Aorig)).Value = Aorig
  Range("A2:D2").Offset(UBound(Aorig)).Resize(UBound(Borig)).Value = Borig
  Range("A2:D2").Offset(UBound(Aorig) + UBound(Borig)).Resize(UBound(Corig)).Value = Corig
  Application.ScreenUpdating = True
End Sub

Sub ReloadDic(d As Object, aData As Variant, WaitPeriod As Long, AlreadyUsed As Variant)
  Dim r As Long, k As Long, NumUsed As Long
  
  k = 0
  NumUsed = UBound(Filter(Split("|" & Join(AlreadyUsed, "|#|") & "|", "#"), "||", False)) + 1
  Do While d.Count = 0 And k <= WaitPeriod
    For r = 1 To UBound(aData)
      If aData(r, 4) <= Date - WaitPeriod + k Then d(aData(r, 1)) = r
    Next r
    For r = 1 To NumUsed
      If d.exists(AlreadyUsed(r)) Then d.Remove AlreadyUsed(r)
    Next r
    k = k + 1
  Loop
End Sub
 
Solution

dchapman17

New Member
Joined
May 18, 2021
Messages
8
Good morning all.

Peter kindly provided the code in post #13 and it has been working perfectly. We have since reviewed our data and have now compiled a complete list;

Category A - 323 entires
Category B - 491 entries
Category C - 3106 entries

I have attempted to increase the number of daily checks by amending the code from;

Const NoRepeatA As Long = 21
Const NoRepeatB As Long = 42
Const NoRepeatC As Long = 208
Const Apicks As Long = 10
Const Bpicks As Long = 3
Const CPicks As Long = 1
Const ResultCol As String = "K"

to;

Const NoRepeatA As Long = 21
Const NoRepeatB As Long = 42
Const NoRepeatC As Long = 208
Const Apicks As Long = 15
Const Bpicks As Long = 11
Const CPicks As Long = 11
Const ResultCol As String = "K"

however I receive the following error message when I try to run the report;

1634625417464.png


I'd be grateful for any advice on how to change the original code in post #13 so that the daily checks are;
Category A - was 10 per day, now 15 per day
Category B - was 3 per day, now 11 per day
Category C - was 1 per day, now 11 per day

Thank you in advance for the help and advice.

Dan
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
52,372
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

This was from a long time ago so I am not immediately familiar with it again. However, I have some comments:

however I receive the following error message when I try to run the report;
Your image possibly shows what line the error occurred on but not what the error message actually said. :)

I still have my test workbook from back then and made the 3 changes shown to the code. It ran without error for me and produced a new column of values with 15, 11 and 11 values as expected.
That would seem to indicate either ..
- something significant has changed with your data &/or layout, or
- other changes have also been made to the code originally posted.

If you would like further investigation then, since you are not able to use XL2BB, could you remove/disguise any sensitive information in the workbook and upload it to DropBox or OneDrive or Google Drive etc and provide a shared link here.
 

dchapman17

New Member
Joined
May 18, 2021
Messages
8
Good morning Peter,

Thanks for the reply.

I was using different data but on the same sheet. I have now played with the original data and the issue is resolved.
 
Master Excel Bundle

Excel contains over 450 functions, with more added every year. That’s a huge number, so where should you start? Right here with this bundle.

Forum statistics

Threads
1,152,564
Messages
5,770,886
Members
425,649
Latest member
cbTexas

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
Top