VBA Randomly Distribute A,B,C,D,E Evenly

Stephen_IV

Well-known Member
Joined
Mar 17, 2003
Messages
966
I have a data set that I would like to have A,B,C,D,E distributed evenly. Below is a sample, I would like to use this on a larger data set. If anyone has a Function or VBA I would appreciate it. Thanks in advance!

STUDENT 1 B
STUDENT 2 C
STUDENT 3 D
STUDENT 4 E
STUDENT 5 B
STUDENT 6 A
STUDENT 7 D
STUDENT 8 A
STUDENT 9 C
STUDENT 10 A
STUDENT 11 B
STUDENT 12 E
STUDENT 13 D
STUDENT 14 C
STUDENT 15 C
STUDENT 16 A
STUDENT 17 E
STUDENT 18 B
STUDENT 19 E
STUDENT 20 D
 

Some videos you may like

Excel Facts

Select all contiguous cells
Pressing Ctrl+* (asterisk) will select the "current region" - all contiguous cells in all directions.

shg

MrExcel MVP
Joined
May 7, 2008
Messages
21,752
Office Version
2010
Platform
Windows
A​
B​
C​
D​
E​
F​
1​
Group
Qty
CDF
Check
2​
A​
5​
0​
5​
C2: =SUM(B$1:B1)
3​
B​
5​
5​
5​
D2: =COUNTIF($B$10:$B$29, A2)
4​
C​
5​
10​
5​
5​
D​
5​
15​
5​
6​
20​
B6: =SUM(B2:B5)
7​
8​
9​
Student
Group
10​
1​
B​
B10: {=INDEX(A$2:A$5, MATCH(RANDBETWEEN(0, B$6 - ROWS(B$9:B9)), $C$2:$C$5 - COUNTIF(B9:B$9, "<" & A$2:A$5)))}
11​
2​
C​
12​
3​
D​
13​
4​
A​
14​
5​
B​
15​
6​
D​
16​
7​
A​
17​
8​
A​
18​
9​
C​
19​
10​
B​
20​
11​
A​
21​
12​
D​
22​
13​
D​
23​
14​
A​
24​
15​
B​
25​
16​
C​
26​
17​
D​
27​
18​
C​
28​
19​
B​
29​
20​
C​
 

Rick Rothstein

MrExcel MVP
Joined
Apr 18, 2011
Messages
36,050
Office Version
2010
Platform
Windows
Assuming your data is located in Column A and starts on Row 1 (change the red highlighted text if that guess is wrong), give this macro a try...
Code:
Sub RandomEvenDistributionOf()
  Dim R As Long, Cnt As Long, RndIdx As Long, HowMany As Long, What As String
  Dim Tmp As Variant, Data As Variant, Arr As Variant
  Data = Range("[B][COLOR="#FF0000"]A1[/COLOR][/B]", Cells(Rows.Count, "[B][COLOR="#FF0000"]A[/COLOR][/B]").End(xlUp))
  What = "ABCDE"
  HowMany = UBound(Data)
  Arr = Split(Trim(Replace(StrConv(Application.Rept(What, 1 + Int(HowMany / Len(What))), vbUnicode), Chr(0), " ")))
  Randomize
  For Cnt = UBound(Arr) To LBound(Arr) Step -1
    RndIdx = Int((Cnt - LBound(Arr) + 1) * Rnd + LBound(Arr))
    Tmp = Arr(RndIdx)
    Arr(RndIdx) = Arr(Cnt)
    Arr(Cnt) = Tmp
  Next
  Range("[B][COLOR="#FF0000"]A1[/COLOR][/B]").Offset(,1).Resize(HowMany) = Application.Transpose(Arr)
End Sub
Note: If the number of names is not an even multiple of the number of letters you want to distribute, the "odd excess" will be filled randomly from among the letters being distributed.
 

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
6,368
Office Version
365
Platform
Windows
another VBA option
- if there are 20 students all grades occur 4 times
- if there are 21 students 4 grades occur 4 times, 1 grade occurs 5 times
- if there are 20 students 3 grades occur 4 times, 2 grades occur 5 times
- if there are 20 students 2 grades occur 4 times, 3 grades occur 5 times
- if there are 20 students 1 grade occurs 4 times, 4 grades occur 5 times
- if there are 25 students all grades occur 5 times etc

Code:
Sub Distribute()
    Dim Ws As Worksheet, Rng As Range, Cel As Range, M As Integer, C As Long, a As Long, xMax As Long
    Set Ws = ActiveSheet
    Set Rng = Ws.Range("A2", Ws.Range("A" & Rows.Count).End(xlUp)).Offset(, 1)
    Rng.ClearContents
    C = Rng.Cells.CountLarge            [I][COLOR=#006400]'number of students[/COLOR][/I]
    M = C Mod 5                         [COLOR=#006400][I]'remainder when C is divided by 5[/I][/COLOR]
    xMax = (C - M) / 5                 [I][COLOR=#006400] 'max occurrence for even distribution[/COLOR][/I]
[I][COLOR=#006400]'allocate excluding remainder[/COLOR][/I]
    For a = 1 To C - M
        Set Cel = Rng(a, 1)
        Cel = Chr(WorksheetFunction.RoundUp(Rnd * 5, 0) + 64)
        If WorksheetFunction.CountIf(Rng, Cel) > xMax Then a = a - 1
    Next a
[I][COLOR=#006400]'allocate the remainder[/COLOR][/I]
    For a = C - M + 1 To C
        Set Cel = Rng(a, 1)
        Cel = GetGrade
        If WorksheetFunction.CountIf(Rng, Cel) > xMax + 1 Then a = a - 1
    Next a
End Sub

Student names are in column A starting at A2 (without any blank cells)

Results will differ every time the code is run
- example

Excel 2016 (Windows) 32 bit
A
B
C
D
E
F
1
StudentRESULTGradeCOUNT
2
STUDENT 1BA
4​
3
STUDENT 2EB
5​
4
STUDENT 3DC
5​
5
STUDENT 4BD
4​
6
STUDENT 5BE
5​
7
STUDENT 6E
8
STUDENT 7C
9
STUDENT 8E
10
STUDENT 9C
11
STUDENT 10B
12
STUDENT 11E
13
STUDENT 12A
14
STUDENT 13A
15
STUDENT 14D
16
STUDENT 15D
17
STUDENT 16C
18
STUDENT 17D
19
STUDENT 18C
20
STUDENT 19A
21
STUDENT 20A
22
STUDENT 21C
23
STUDENT 22E
24
STUDENT 23B
25
Sheet: Sheet1
 
Last edited:

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,209
Office Version
2007
Platform
Windows
With formulas

<table border="1" cellspacing="0" style="font-family:Calibri,Arial; font-size:11pt; background-color:#ffffff; "> <colgroup><col style="font-weight:bold; width:30px; " /><col style="width:76.04px;" /><col style="width:85.54px;" /><col style="width:79.84px;" /><col style="width:249.98px;" /><col style="width:44.67px;" /></colgroup><tr style="background-color:#cacaca; text-align:center; font-weight:bold; font-size:8pt; "><td > </td><td >A</td><td >B</td><td >C</td><td >D</td><td >E</td></tr><tr style="height:19px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >1</td><td style="background-color:#92d050; font-weight:bold; text-align:center; ">STUDENT</td><td style="background-color:#92d050; font-weight:bold; text-align:center; ">FINAL GROUP</td><td style="background-color:#92d050; font-weight:bold; text-align:center; ">RANDOM</td><td style="background-color:#92d050; font-weight:bold; text-align:center; ">GROUP repeat from A to B</td><td style="background-color:#92d050; font-weight:bold; text-align:center; ">CHECK</td></tr><tr style="height:19px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >2</td><td >STUDENT 1</td><td >A</td><td style="text-align:right; ">0.950053729</td><td style="background-color:#ffc000; text-align:center; ">A</td><td style="text-align:right; ">4</td></tr><tr style="height:19px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >3</td><td >STUDENT 2</td><td >B</td><td style="text-align:right; ">0.162449816</td><td style="background-color:#ffc000; text-align:center; ">B</td><td style="text-align:right; ">4</td></tr><tr style="height:19px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >4</td><td >STUDENT 3</td><td >E</td><td style="text-align:right; ">0.493879798</td><td style="background-color:#ffc000; text-align:center; ">C</td><td style="text-align:right; ">4</td></tr><tr style="height:19px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >5</td><td >STUDENT 4</td><td >C</td><td style="text-align:right; ">0.36720584</td><td style="background-color:#ffc000; text-align:center; ">D</td><td style="text-align:right; ">4</td></tr><tr style="height:19px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >6</td><td >STUDENT 5</td><td >D</td><td style="text-align:right; ">0.301664141</td><td style="background-color:#ffc000; text-align:center; ">E</td><td style="text-align:right; ">4</td></tr><tr style="height:19px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >7</td><td >STUDENT 6</td><td >D</td><td style="text-align:right; ">0.558129856</td><td style="text-align:center; ">A</td><td > </td></tr><tr style="height:19px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >8</td><td >STUDENT 7</td><td >C</td><td style="text-align:right; ">0.274059549</td><td style="text-align:center; ">B</td><td > </td></tr><tr style="height:19px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >9</td><td >STUDENT 8</td><td >B</td><td style="text-align:right; ">0.415170288</td><td style="text-align:center; ">C</td><td > </td></tr><tr style="height:19px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >10</td><td >STUDENT 9</td><td >E</td><td style="text-align:right; ">0.182926025</td><td style="text-align:center; ">D</td><td > </td></tr><tr style="height:19px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >11</td><td >STUDENT 10</td><td >E</td><td style="text-align:right; ">0.092627143</td><td style="text-align:center; ">E</td><td > </td></tr><tr style="height:19px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >12</td><td >STUDENT 11</td><td >C</td><td style="text-align:right; ">0.161204425</td><td style="text-align:center; ">A</td><td > </td></tr><tr style="height:19px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >13</td><td >STUDENT 12</td><td >A</td><td style="text-align:right; ">0.476992103</td><td style="text-align:center; ">B</td><td > </td></tr><tr style="height:19px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >14</td><td >STUDENT 13</td><td >A</td><td style="text-align:right; ">0.278864691</td><td style="text-align:center; ">C</td><td > </td></tr><tr style="height:19px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >15</td><td >STUDENT 14</td><td >C</td><td style="text-align:right; ">0.57026593</td><td style="text-align:center; ">D</td><td > </td></tr><tr style="height:19px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >16</td><td >STUDENT 15</td><td >B</td><td style="text-align:right; ">0.275809365</td><td style="text-align:center; ">E</td><td > </td></tr><tr style="height:19px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >17</td><td >STUDENT 16</td><td >A</td><td style="text-align:right; ">0.817885174</td><td style="text-align:center; ">A</td><td > </td></tr><tr style="height:19px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >18</td><td >STUDENT 17</td><td >B</td><td style="text-align:right; ">0.690742645</td><td style="text-align:center; ">B</td><td > </td></tr><tr style="height:19px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >19</td><td >STUDENT 18</td><td >D</td><td style="text-align:right; ">0.104926195</td><td style="text-align:center; ">C</td><td > </td></tr><tr style="height:19px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >20</td><td >STUDENT 19</td><td >E</td><td style="text-align:right; ">0.28160362</td><td style="text-align:center; ">D</td><td > </td></tr><tr style="height:19px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >21</td><td >STUDENT 20</td><td >D</td><td style="text-align:right; ">0.273532275</td><td style="text-align:center; ">E</td><td > </td></tr></table><br /><table style="font-family:Arial; font-size:10pt; border-style: groove ;border-color:#00ff00;background-color:#fffcf9; color:#000000; "><tr><td ><b></b></td></tr><tr><td ><table border = "1" cellspacing="0" cellpadding="2" style="font-family:Arial; font-size:9pt;"><tr style="background-color:#cacaca; font-size:10pt;"><td >Cell</td><td >Formula</td></tr><tr><td >B2</td><td >=INDEX($D$2:$D$21,RANK(C2,$C$2:$C$21))</td></tr><tr><td >C2</td><td >=RAND()</td></tr><tr><td >E2</td><td >=COUNTIF($B$2:$B$21,D2)</td></tr></table></td></tr></table>

After obtaining the results, you must copy column C and paste as values ​​so that the results no longer move.
 

Rick Rothstein

MrExcel MVP
Joined
Apr 18, 2011
Messages
36,050
Office Version
2010
Platform
Windows
Code:
Sub Distribute()
    Dim Ws As Worksheet, Rng As Range, Cel As Range, M As Integer, C As Long, a As Long, xMax As Long
    Set Ws = ActiveSheet
    Set Rng = Ws.Range("A2", Ws.Range("A" & Rows.Count).End(xlUp)).Offset(, 1)
    Rng.ClearContents
    C = Rng.Cells.CountLarge            [I][COLOR=#006400]'number of students[/COLOR][/I]
    M = C Mod 5                         [COLOR=#006400][I]'remainder when C is divided by 5[/I][/COLOR]
    xMax = (C - M) / 5                 [I][COLOR=#006400] 'max occurrence for even distribution[/COLOR][/I]
[I][COLOR=#006400]'allocate excluding remainder[/COLOR][/I]
    For a = 1 To C - M
        Set Cel = Rng(a, 1)
        Cel = Chr(WorksheetFunction.RoundUp(Rnd * 5, 0) + 64)
        If WorksheetFunction.CountIf(Rng, Cel) > xMax Then a = a - 1
    Next a
[I][COLOR=#006400]'allocate the remainder[/COLOR][/I]
    For a = C - M + 1 To C
        Set Cel = Rng(a, 1)
        Cel = [COLOR=#ff0000][B]GetGrade[/B][/COLOR]
        If WorksheetFunction.CountIf(Rng, Cel) > xMax + 1 Then a = a - 1
    Next a
End Sub
What is GetGrade (see red highlighted text above)? This seems to be the only appearance of it in all of your posted code.

Also, you need to include a Randomize statement in your code or I think it will repeat the same sequence each time the workbook is opened.
 
Last edited:

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
6,368
Office Version
365
Platform
Windows
Thanks @Rick Rothstein


ooops :oops:
I had a function which I decided to remove - changed one line and forgot to change the other !!
Of couse it still worked for me

Code:
Sub Distribute()
    Dim Ws As Worksheet, Rng As Range, Cel As Range, M As Integer, C As Long, a As Long, xMax As Long
    Set Ws = ActiveSheet
    Set Rng = Ws.Range("A2", Ws.Range("A" & Rows.Count).End(xlUp)).Offset(, 1)
    Rng.ClearContents
    C = Rng.Cells.CountLarge            'number of students
    M = C Mod 5                         'remainder when C is divided by 5
    xMax = (C - M) / 5                  'max occurrence for even distribution
'allocate excluding remainder
    For a = 1 To C - M
        Set Cel = Rng(a, 1)
        [COLOR=#006400]Cel = Chr(WorksheetFunction.RoundUp(Rnd * 5, 0) + 64)[/COLOR]
        If WorksheetFunction.CountIf(Rng, Cel) > xMax Then a = a - 1
    Next a
'allocate the remainder
    For a = C - M + 1 To C
        Set Cel = Rng(a, 1)
        [COLOR=#006400]Cel = Chr(WorksheetFunction.RoundUp(Rnd * 5, 0) + 64)[/COLOR]
        If WorksheetFunction.CountIf(Rng, Cel) > xMax + 1 Then a = a - 1
    Next a
End Sub
 
Last edited:

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
6,368
Office Version
365
Platform
Windows
Also, you need to include a Randomize statement in your code or I think it will repeat the same sequence each time the workbook is opened
@Rick Rothstein - tested that and you are correct
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,209
Office Version
2007
Platform
Windows
I'm glad to help you. Thanks for the feedback.
 

Watch MrExcel Video

Forum statistics

Threads
1,102,731
Messages
5,488,543
Members
407,645
Latest member
suyoggore

This Week's Hot Topics

  • Timer in VBA - Stop, Start, Pause and Reset
    [CODE=vba][/CODE] Option Explicit Dim CmdStop As Boolean Dim Paused As Boolean Dim Start Dim TimerValue As Date Dim pausedTime As Date Sub...
  • how to updates multiple rows in muliselect listbox
    Hello everyone. I need help with below code. code is only chaning 1st row in mulitiselect list box. i know issue with code...
  • Delete Row from Table
    I am trying to delete a row from a table using VBA using a named range to find what I need to delete. My Range is finding the right cell. In the...
  • Assigning to a variable
    I have a for each block where I want to assign the value in column 5 of the found row to the variable Serv. [CODE=vba] For Each ws In...
  • Way to verify information
    Hi All, I don't know what to call this formula, and therefore can't search. I have a spreadsheet with information I want to reference...
  • Active Cell Address – Inactive Sheet
    How to use VBA to get the cell address of the active cell in an inactive worksheet and then place that cell address in a location on the current...
Top