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

[dchapman17]

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.

 

[Peter_SSs]

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.

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
	A	B	C	D	E					J	K	L	M
1	Part	Desc	Cat	Last Checked							19/05/2021	18/05/2021	17/05/2021
2	1	A_Dummy 1	A								A_Dummy 69	A_Dummy 146	A_Dummy 186
3	2	A_Dummy 2	A								A_Dummy 73	A_Dummy 76	A_Dummy 200
4	3	A_Dummy 3	A								A_Dummy 119	A_Dummy 43	A_Dummy 35
5	4	A_Dummy 4	A								A_Dummy 95	A_Dummy 50	A_Dummy 162
6	5	A_Dummy 5	A	18/05/2021							A_Dummy 165	A_Dummy 145	A_Dummy 194
7	6	A_Dummy 6	A								A_Dummy 189	A_Dummy 5	A_Dummy 75
8	7	A_Dummy 7	A								A_Dummy 71	A_Dummy 128	A_Dummy 129
9	8	A_Dummy 8	A								A_Dummy 16	A_Dummy 27	A_Dummy 137
10	9	A_Dummy 9	A								A_Dummy 106	A_Dummy 164	A_Dummy 148
11	10	A_Dummy 10	A								A_Dummy 61	A_Dummy 170	A_Dummy 205
12	11	A_Dummy 11	A								B_Dummy 97	B_Dummy 45	B_Dummy 11
13	12	A_Dummy 12	A								B_Dummy 52	B_Dummy 109	B_Dummy 75
14	13	A_Dummy 13	A								B_Dummy 14	B_Dummy 34	B_Dummy 62
15	14	A_Dummy 14	A								C_Dummy 15	C_Dummy 140	C_Dummy 92
16	15	A_Dummy 15	A
17	16	A_Dummy 16	A	19/05/2021
18	17	A_Dummy 17	A
19	18	A_Dummy 18	A
20	19	A_Dummy 19	A
21	20	A_Dummy 20	A
22	21	A_Dummy 21	A
23	22	A_Dummy 22	A
24	23	A_Dummy 23	A
25	24	A_Dummy 24	A
26	25	A_Dummy 25	A
27	26	A_Dummy 26	A
28	27	A_Dummy 27	A	18/05/2021
29	28	A_Dummy 28	A
30	29	A_Dummy 29	A
31	30	A_Dummy 30	A
32	31	A_Dummy 31	A
33	32	A_Dummy 32	A
34	33	A_Dummy 33	A
35	34	A_Dummy 34	A
36	35	A_Dummy 35	A	17/05/2021
Sheet1

 

[dchapman17]

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]

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.

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

 

[dchapman17]

Thank you Peter, this works perfectly.

 

[Peter_SSs]

Thank you Peter, this works perfectly.

You're welcome. Thanks for the confirmation.

 

[dchapman17]

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;

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]

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]

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.

 

[Peter_SSs]

the issue is resolved.

Good news! Thanks for letting us know.