VBA How to auto populate number randomly with criteria that each person must be picked once

[AmirFirdaus9509]

Hi , I Am currently creating an Audit Tool for Excel.
I have create a VBA where the function will calculate the total number based on each name and its respective class from a raw data in Tab "Raw Data" and populate them into Table Below .However , To do the audit , i would ask the auditor to add up the number themselves in column K till Q but this is not a fair way to segregate the audit. I would like the excel to randomly add it but with criteria that atleast 1 name should be picked at all times.

Is there a way in Column K6 to Q6 to down below to randomly add up to the number based on green cell on Column D3 to J3?

Thanks and greatly appreciated on the help

 

[Snakehips]

@AmirFirdaus9509 Are columns S:X freely available to be momentarily used in this process?

 

[AmirFirdaus9509]

@AmirFirdaus9509 Are columns S:X freely available to be momentarily used in this process?

Hi thanks for the reply
, yes it is free to use for any necessary process

 

[Snakehips]

I couple more questions/confirmations if I may.
1) What is likely max number of rows, ie names listed?
1) Each name will have at least one AWB count value in D:J ?
2) Each name is required to have at least one audit?
3) Other than condition 2), the selection is random?
4) If column entries >= to audits required (green) then only one audit per name for that column?
The above I believe I can achieve.

Where it gets a bit more difficult, for me, is....
4) If number of audits required (Green) exceeds number of entries in it's column, then multiple audits are allocated?
Hopefully that makes sense?

 

[Snakehips]

Ok, maybe best to run this by you. Below is my test data and the code that creating the random selection, albeit that they are all 1's.
Maybe copy it and test to see if I am on the track?

AutoTraining.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q
1
2
3				3	1	17	2	4	2	1
4
5		N0	Name
6		1	NM1	2							1
7		2	NM2	8	1		3	16						1	1
8		3	NM3	15				34	7						1	1
9		4	NM4					32							1
10		5	NM5	2		6		17	3		1		1		1
11		6	NM6			64							1
12		7	NM7			60							1
13		8	NM8			59							1
14		9	NM9	22							1
15		10	NM10				3							1
16		11	NM11		1							1
17		12	NM12						2							1
18		13
19		14
20		15
21		16
22		17
23		18
24		19
25		20
26
Sheet8

Sub RandAudit()

Dim lr As Long, i As Long
Dim Rng1 As Range, Rng2 As Range, Rng3 As Range

lr = Range("C" & Rows.Count).End(xlUp).Row
Set Rng1 = Range("K6:Q" & lr)
Set Rng2 = Range("S6:X" & lr)
Set Rng3 = Range("S6:S" & lr)

Application.ScreenUpdating = False
Application.EnableEvents = False
For i = 1 To 200
      Rng2.Formula = "=IF(D6>0,RAND(),"""")"
       Rng2.Value = Rng2.Value
    Rng1.Formula = "=IFERROR(IF(RANK(S6,S$6:S$" & lr & ",0)<=D$3,1,""""),"""")"
    Rng1.Value = Rng1.Value
    Rng2.ClearContents
    
    Rng3.Formula = "=SUM(K6:Q6)>0"
    If Application.WorksheetFunction.CountIf(Rng3, True) = lr - 5 Then Exit For

Next
Rng3.ClearContents
Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub

 

[AmirFirdaus9509]

Hi , sorry for my belated reply as it was night time in my zone

To answer your question .

1. At max , will be 15 names at all times.
2. Yes , If they are working on that day , atleast one AWB will be shown up
3. Correct , the previous version is totally random that may not picked the user name.
4. Yes , I would like the excel to choose it for the auditor. Yes , it is expect to exceed but i would like for atleast all user to be picked.

I couple more questions/confirmations if I may.
1) What is likely max number of rows, ie names listed?
1) Each name will have at least one AWB count value in D:J ?
2) Each name is required to have at least one audit?
3) Other than condition 2), the selection is random?
4) If column entries >= to audits required (green) then only one audit per name for that column?
The above I believe I can achieve.

Where it gets a bit more difficult, for me, is....
4) If number of audits required (Green) exceeds number of entries in it's column, then multiple audits are allocated?
Hopefully that makes sense

 

[AmirFirdaus9509]

Ok, maybe best to run this by you. Below is my test data and the code that creating the random selection, albeit that they are all 1's.
Maybe copy it and test to see if I am on the track?

AutoTraining.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q
1
2
3				3	1	17	2	4	2	1
4
5		N0	Name
6		1	NM1	2							1
7		2	NM2	8	1		3	16						1	1
8		3	NM3	15				34	7						1	1
9		4	NM4					32							1
10		5	NM5	2		6		17	3		1		1		1
11		6	NM6			64							1
12		7	NM7			60							1
13		8	NM8			59							1
14		9	NM9	22							1
15		10	NM10				3							1
16		11	NM11		1							1
17		12	NM12						2							1
18		13
19		14
20		15
21		16
22		17
23		18
24		19
25		20
26
Sheet8

Sub RandAudit()

Dim lr As Long, i As Long
Dim Rng1 As Range, Rng2 As Range, Rng3 As Range

lr = Range("C" & Rows.Count).End(xlUp).Row
Set Rng1 = Range("K6:Q" & lr)
Set Rng2 = Range("S6:X" & lr)
Set Rng3 = Range("S6:S" & lr)

Application.ScreenUpdating = False
Application.EnableEvents = False
For i = 1 To 200
      Rng2.Formula = "=IF(D6>0,RAND(),"""")"
       Rng2.Value = Rng2.Value
    Rng1.Formula = "=IFERROR(IF(RANK(S6,S$6:S$" & lr & ",0)<=D$3,1,""""),"""")"
    Rng1.Value = Rng1.Value
    Rng2.ClearContents
  
    Rng3.Formula = "=SUM(K6:Q6)>0"
    If Application.WorksheetFunction.CountIf(Rng3, True) = lr - 5 Then Exit For

Next
Rng3.ClearContents
Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub

I tested your sample code and it is on the right track in randomize the selection when run multiple times,
Is there a way to add up the number to 11 instead of 1's , it will provide an add up lets just say 5+4+2?

 

[Snakehips]

I tested your sample code and it is on the right track in randomize the selection when run multiple times,
Is there a way to add up the number to 11 instead of 1's , it will provide an add up lets just say 5+4+2?

Hi, I'm not sure I understand the adding up to 11 , 5+4+2.
Can you illustrate / provide the broad logic behind it?

 

[AmirFirdaus9509]

Hi , apologize if my explanation is not clear.
Please find the screenshot below.

Since the other column is added correctly to the green box for each row.
Would it be possible for it to randomly choose and add up the number base on the total number?

I hope this is clear

Furthermore , could the random chosen follow the existing number under "Count in AWB Raw Data"
For example , in BIS column for both blue and white box is not align on the existing AWB instead it is selecting for the person who did not do the BIS for the day

 

[Snakehips]

OK, I think this is probably my best shot.

AutoTraining.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R
1
2
3				3	1	17	2	4	2	1
4
5		N0	Name
6		1	NM1	2							1
7		2	NM2	8	1		3	16				1		1	1
8		3	NM3	15				34	7						1
9		4	NM4					32							2
10		5	NM5	2		3			3		1		3			1
11		6	NM6			64							4
12		7	NM7			4							4
13		8	NM8			59							6
14		9	NM9	22							1
15		10	NM10				3							1
16		11	NM11
17		12	NM12						2							1
18		13
19		14
20		15
21		16
22		17
23		18
24		19
25		20
26
Sheet8 (2)

Sub RandAudit()

Dim lr As Integer, os As Integer, i As Integer
Dim Auds As Integer, AudsCount As Integer, NameCount As Integer
Dim Rng1 As Range, Rng2 As Range, Rng3 As Range
Dim Rng4 As Range, Rng5 As Range, Rng6 As Range
Dim Cel As Range


lr = Range("C" & Rows.Count).End(xlUp).Row
Set Rng1 = Range("K6:Q" & lr)
Set Rng2 = Range("S6:X" & lr)   'Columns S:X used as temporary 'helper' range
Set Rng3 = Range("S6:S" & lr)   'Column S used as temporary 'helper' range

Application.ScreenUpdating = False
Application.EnableEvents = False
'loop the randomisation up to 200 times to try and ensure all names get an audit
For i = 1 To 200
      Rng2.Formula = "=IF(D6>0,RAND(),"""")"
       Rng2.Value = Rng2.Value
    Rng1.Formula = "=IFERROR(IF(RANK(S6,S$6:S$" & lr & ",0)<=D$3,1,""""),"""")"
    Rng1.Value = Rng1.Value
    Rng2.ClearContents  'Clear the 'he;per' range
    
   'Use S as 'helper' column to check if all names have atleast 1 audit
   Rng3.Formula = "=OR(SUM(K6:Q6)>0,SUM(D6:J6)=0)"
    'If yes thenquit the randomise loop
    If Application.WorksheetFunction.CountIf(Rng3, True) = lr - 5 Then Exit For

Next

Rng3.ClearContents 'Clear the 'helper'

'Check column by column for need to allocate more than one audit
For os = 0 To 6  'column offset

    Set Rng4 = Range("K6:K" & lr).Offset(0, os)
    Set Rng5 = Range("D6:J" & lr).Offset(0, os)
    Set Rng6 = Range("D3").Offset(0, os)
        
    'only need to process if required audits exceed column's entries
    If WorksheetFunction.CountA(Rng4) < Rng6 Then
    On Error Resume Next   ' ignore potential runtime error if column has no entries
        NameCount = WorksheetFunction.CountA(Rng4)
         
        AudsBal = Rng6
        Auds = Int(AudsBal / NameCount)
        'check row by row and apportion required audits
            For Each Cel In Rng4.Cells
                If Cel > 0 Then
                     orig = Cel.Offset(0, -7)
                    Cel.Value = WorksheetFunction.Min(Auds, orig)
                    NameCount = NameCount - 1
                    AudsBal = AudsBal - Cel.Value
                    Auds = Int(AudsBal / NameCount)
                End If
                If NameCount = 0 Then Exit For
            Next Cel
        On Error GoTo 0  'reset error default
    End If
 
Next os     'next os  ie next column


Application.ScreenUpdating = True
Application.EnableEvents = True


End Sub

Hope that helps?