Results 1 to 10 of 10

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

  1. #1
    Board Regular
    Join Date
    Mar 2003
    Posts
    950
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

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

    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

  2. #2
    MrExcel MVP shg's Avatar
    Join Date
    May 2008
    Location
    The Great State of Texas
    Posts
    21,613
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    14 Thread(s)

    Default Re: VBA Randomly Distribute A,B,C,D,E Evenly

    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

  3. #3
    MrExcel MVP Rick Rothstein's Avatar
    Join Date
    Apr 2011
    Location
    New Jersey, USA
    Posts
    35,252
    Post Thanks / Like
    Mentioned
    92 Post(s)
    Tagged
    33 Thread(s)

    Default Re: VBA Randomly Distribute A,B,C,D,E Evenly

    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("A1", Cells(Rows.Count, "A").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("A1").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.
    Rick's "mini" blog... http://www.excelfox.com/forum/f22/
    .
    Want to post a small screen shot? See Part B here.

  4. #4
    Board Regular
    Join Date
    Mar 2015
    Posts
    3,923
    Post Thanks / Like
    Mentioned
    72 Post(s)
    Tagged
    7 Thread(s)

    Default Re: VBA Randomly Distribute A,B,C,D,E Evenly

    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            '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)
            Cel = Chr(WorksheetFunction.RoundUp(Rnd * 5, 0) + 64)
            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)
            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
    Student RESULT Grade COUNT
    2
    STUDENT 1 B A
    4
    3
    STUDENT 2 E B
    5
    4
    STUDENT 3 D C
    5
    5
    STUDENT 4 B D
    4
    6
    STUDENT 5 B E
    5
    7
    STUDENT 6 E
    8
    STUDENT 7 C
    9
    STUDENT 8 E
    10
    STUDENT 9 C
    11
    STUDENT 10 B
    12
    STUDENT 11 E
    13
    STUDENT 12 A
    14
    STUDENT 13 A
    15
    STUDENT 14 D
    16
    STUDENT 15 D
    17
    STUDENT 16 C
    18
    STUDENT 17 D
    19
    STUDENT 18 C
    20
    STUDENT 19 A
    21
    STUDENT 20 A
    22
    STUDENT 21 C
    23
    STUDENT 22 E
    24
    STUDENT 23 B
    25
    Sheet: Sheet1
    Last edited by Yongle; Aug 17th, 2019 at 11:04 AM.

  5. #5
    Board Regular DanteAmor's Avatar
    Join Date
    Dec 2018
    Location
    México
    Posts
    6,337
    Post Thanks / Like
    Mentioned
    73 Post(s)
    Tagged
    14 Thread(s)

    Default Re: VBA Randomly Distribute A,B,C,D,E Evenly

    With formulas

     ABCDE
    1STUDENTFINAL GROUPRANDOMGROUP repeat from A to BCHECK
    2STUDENT 1A0.950053729A4
    3STUDENT 2B0.162449816B4
    4STUDENT 3E0.493879798C4
    5STUDENT 4C0.36720584D4
    6STUDENT 5D0.301664141E4
    7STUDENT 6D0.558129856A 
    8STUDENT 7C0.274059549B 
    9STUDENT 8B0.415170288C 
    10STUDENT 9E0.182926025D 
    11STUDENT 10E0.092627143E 
    12STUDENT 11C0.161204425A 
    13STUDENT 12A0.476992103B 
    14STUDENT 13A0.278864691C 
    15STUDENT 14C0.57026593D 
    16STUDENT 15B0.275809365E 
    17STUDENT 16A0.817885174A 
    18STUDENT 17B0.690742645B 
    19STUDENT 18D0.104926195C 
    20STUDENT 19E0.28160362D 
    21STUDENT 20D0.273532275E 

    CellFormula
    B2=INDEX($D$2:$D$21,RANK(C2,$C$2:$C$21))
    C2=RAND()
    E2=COUNTIF($B$2:$B$21,D2)


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

  6. #6
    MrExcel MVP Rick Rothstein's Avatar
    Join Date
    Apr 2011
    Location
    New Jersey, USA
    Posts
    35,252
    Post Thanks / Like
    Mentioned
    92 Post(s)
    Tagged
    33 Thread(s)

    Default Re: VBA Randomly Distribute A,B,C,D,E Evenly

    Quote Originally Posted by Yongle View Post
    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)
            Cel = Chr(WorksheetFunction.RoundUp(Rnd * 5, 0) + 64)
            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)
            Cel = GetGrade
            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 by Rick Rothstein; Aug 17th, 2019 at 11:38 AM.
    Rick's "mini" blog... http://www.excelfox.com/forum/f22/
    .
    Want to post a small screen shot? See Part B here.

  7. #7
    Board Regular
    Join Date
    Mar 2015
    Posts
    3,923
    Post Thanks / Like
    Mentioned
    72 Post(s)
    Tagged
    7 Thread(s)

    Default Re: VBA Randomly Distribute A,B,C,D,E Evenly

    Thanks @Rick Rothstein


    ooops
    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)
            Cel = Chr(WorksheetFunction.RoundUp(Rnd * 5, 0) + 64)
            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)
            Cel = Chr(WorksheetFunction.RoundUp(Rnd * 5, 0) + 64)
            If WorksheetFunction.CountIf(Rng, Cel) > xMax + 1 Then a = a - 1
        Next a
    End Sub
    Last edited by Yongle; Aug 17th, 2019 at 12:23 PM.

  8. #8
    Board Regular
    Join Date
    Mar 2015
    Posts
    3,923
    Post Thanks / Like
    Mentioned
    72 Post(s)
    Tagged
    7 Thread(s)

    Default Re: VBA Randomly Distribute A,B,C,D,E Evenly

    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

  9. #9
    Board Regular
    Join Date
    Mar 2003
    Posts
    950
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: VBA Randomly Distribute A,B,C,D,E Evenly

    Wow!!!! Thank you all!! I greatly appreciate it!!!! I appreciate all of the approaches!!!

  10. #10
    Board Regular DanteAmor's Avatar
    Join Date
    Dec 2018
    Location
    México
    Posts
    6,337
    Post Thanks / Like
    Mentioned
    73 Post(s)
    Tagged
    14 Thread(s)

    Default Re: VBA Randomly Distribute A,B,C,D,E Evenly

    I'm glad to help you. Thanks for the feedback.
    Regards Dante Amor

Some videos you may like

User Tag List

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •