VBA : Allocate Data Randomly and Evenly

[Samantha27]

Hello Good People,

I have this allocation workbook that when I click a button. It will randomly divide the list of data into 8. (Currently 8 but it will soon increase).

I have attached a sample images for my 2 sheets.

Persons sheet - List of data
Teams sheet - Output of allocation

However, I'm having a problem with this line of code

teamsSheet.Cells(startRow, startCol).Value = personsSheet.Cells(personNumber, 2).Value

Also, it only set to 10 and should exclude the header of Persons sheet whenever I click the button.

What I wanted to achieve is to divide the data randomly and evenly to the 8 employee.

Below is my full code. Hoping someone could help me on this, Thank youuuu guys in advance.

Public Sub CreateTeams_BtnClick()
CreateTeams
End Sub
Private Sub CreateTeams()
Dim teamsSheet, personsSheet As Worksheet
Set teamsSheet = Worksheets("Teams")
Set personsSheet = Worksheets("Persons")


personsSheet.Range("A:A").Copy Destination:=personsSheet.Range("B:B")

Dim numPersons As Integer
numPersons = personsSheet.Range("B:B").End(xlDown).Row

Dim startRow As Integer
startRow = 2
Dim startCol As Integer
startCol = 1
Dim personNumber As Integer

For i = 2 To 8
    For j = 1 To 10
        personNumber = Int((numPersons - 1 + 1) * Rnd() + 1)
        teamsSheet.Cells(startRow, startCol).Value = personsSheet.Cells(personNumber, 2).Value
        personsSheet.Cells(personNumber, 2).Delete Shift:=xlUp
        numPersons = numPersons - 1
        startRow = startRow + 1
    Next j

    If i < 8 Then
        startRow = 2
        startCol = startCol + 1
    ElseIf i = 8 Then
        startRow = 14
        startCol = 1
    Else
        startRow = 14
        startCol = startCol + 1
    End If
Next i
End Sub

 

[Eric W]

See if this works for you:

Public Sub CreateTeams_BtnClick()
    CreateTeams
End Sub

Private Sub CreateTeams()
Dim TopPerson As Range, TopTeam As Range, MyOut() As Variant, Persons As Variant
Dim NumTeams As Long, NP As Long, r As Long, c As Long, x As Double

    Set TopPerson = Worksheets("Persons").Range("A2")
    Set TopTeam = Worksheets("Teams").Range("A2")
    NumTeams = 8

    Persons = Range(TopPerson, TopPerson.End(xlDown)).Value
    NP = UBound(Persons)
    ReDim MyOut(1 To Int(NP / NumTeams) + IIf((NP Mod NumTeams) > 0, 1, 0), 1 To NumTeams)
   
    r = 1
    c = 1
    While NP > 0
        x = Int(Rnd() * NP) + 1
        MyOut(r, c) = Persons(x, 1)
        Persons(x, 1) = Persons(NP, 1)
        c = c + 1
        If c > NumTeams Then
            c = 1
            r = r + 1
        End If
        NP = NP - 1
    Wend
   
    TopTeam.Resize(UBound(MyOut), NumTeams).Value = MyOut
       
End Sub

In the red lines, set the first line to the sheet name and top cell of the person list. Set the second line to the sheet name and top left cell of the team list. Set the third line to how many teams you want. Let us know how this works.