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]

This tweak may apportion the multiple Audits more proportionally?

Book2
	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	1
8		3	NM3	15				34	7						2	1
9		4	NM4					32							1
10		5	NM5	2		65			3		1		9
11		6	NM6			6							1
12		7	NM7			4							1
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
Sheet1

Sub RandAudit2()

Dim lr As Integer, os As Integer, i As Integer
Dim tot As Integer, orig 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
        'check row by row and apportion required audits
        
        tot = WorksheetFunction.Sum(Rng4.Offset(0, -7))
            For Each Cel In Rng4.Cells
                If Cel > 0 Then
                     orig = Cel.Offset(0, -7)
                     Auds = Int(orig * AudsBal / tot) + 1
                     If NameCount = 1 Then Auds = AudsBal
                    Cel.Value = WorksheetFunction.Min(Auds, orig)
                    NameCount = NameCount - 1
                    AudsBal = AudsBal - Cel.Value
                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

 

[AmirFirdaus9509]

This tweak may apportion the multiple Audits more proportionally?

Book2
	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	1
8		3	NM3	15				34	7						2	1
9		4	NM4					32							1
10		5	NM5	2		65			3		1		9
11		6	NM6			6							1
12		7	NM7			4							1
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
Sheet1

Sub RandAudit2()

Dim lr As Integer, os As Integer, i As Integer
Dim tot As Integer, orig 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
        'check row by row and apportion required audits
       
        tot = WorksheetFunction.Sum(Rng4.Offset(0, -7))
            For Each Cel In Rng4.Cells
                If Cel > 0 Then
                     orig = Cel.Offset(0, -7)
                     Auds = Int(orig * AudsBal / tot) + 1
                     If NameCount = 1 Then Auds = AudsBal
                    Cel.Value = WorksheetFunction.Min(Auds, orig)
                    NameCount = NameCount - 1
                    AudsBal = AudsBal - Cel.Value
                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

Hi , i tested the code and it segregate the audit more appropriately.

However , multiple test result will maintain its calculation to 6+4+7 instead of randomizing the calculation . It this excel way of calculating the most efficient number?

Furthermore , would it be possible for the audit to capture on who is doing the allocated task for the day?
I try to tweak whether it can crosscheck if the number exist in this blue box it will put the audit number on that user
Currently , it is providing result on user who is not doing for the day

 

[AmirFirdaus9509]

Please find the mini sheet from the excel table that i am testing on.
Maybe the data from blue not showing proper whole number?

VBA Test_Random Audit.xlsm
	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q
3		Total Volume shipment need to be Audit daily	3	1	17	2	4	2	1	* Enter the audit number in this Column K - Column Q
4			Count of AWB In Raw Data							The Number Of Shipment Need To Be Audit
5	No		ACS	BIS	DOD	HRSC	HW	RU/BY	VE	ACS	BIS	DOD	HRSC	HW	RU/BY	VE
6	1	Angela	2			2	12	2				0
7	2	Jafni	18	1		3	16			1	1	0
8	3	Jia	15			5	49	7				0	1	1	1
9	4	Jing	1			1	16			1		0			1
10	5	Vijaya	2			3	17	3		1		0		1
11	6	Mara			64							6		1
12	7	Nayan			60							4
13	8	Rian			59							7	1	1
Audit Volume Matrix