Assign random work position with VBA

[JeanRene]

Hello,

I'd like to assign randomly workers to work tables. Workers are divided in 2 teams (number of worker per team can change). If I have for example 18 workers in team 1, they need to be randomly assigned to position 1 to 18, and if I have 19 workers in team 2, they need to be randomly assigned to position 19 to 37.

I tried to use formula, but the problem with random formula is that it is always recalculating, and also it can assign 2 people to the same position, which I want to avoid.

All help would be welcome...

Thank you

 

[Logit]

Option Explicit

Sub PickNamesAtRandom()

Dim HowMany As Integer
Dim NoOfNames As Long
Dim RandomNumber As Integer
Dim Names() As String 'Array to store randomly selected names
Dim i As Byte
Dim CellsOut As Long 'Variable to be used when entering names onto worksheet
Dim ArI As Byte 'Variable to increment through array indexes

Application.ScreenUpdating = False

HowMany = Range("D3").Value
CellsOut = 6

ReDim Names(1 To HowMany) 'Set the array size to how many names required
NoOfNames = Application.CountA(Range("A:A")) - 1 ' Find how many names in the list
i = 1

Do While i <= HowMany
RandomNo:
    RandomNumber = Application.RandBetween(2, NoOfNames + 1)
    'Check to see if the name has already been picked
    For ArI = LBound(Names) To UBound(Names)
        If Names(ArI) = Cells(RandomNumber, 1).Value Then
            GoTo RandomNo
        End If
    Next ArI
    Names(i) = Cells(RandomNumber, 1).Value ' Assign random name to the array
    i = i + 1
Loop

'Loop through the array and enter names onto the worksheet
For ArI = LBound(Names) To UBound(Names)

    Cells(CellsOut, 4) = Names(ArI)
    CellsOut = CellsOut + 1

Next ArI

Application.ScreenUpdating = True

End Sub

pick-names-at-random.xlsm

 

[JeanRene]

Hi Logit,

Thank you very much for your message! If I understand correctly this code assigns a part of a list of worker to defined list of jobs, correct?

My need is a bit different, I have 2 teams of workers, which I need to assign randomly to workstations. If my teams are made of 18 workers and 19 workers respectively (this number can vary) I need to assign workers from team 1 randomly to workstations 1 to 18, and workers from team 2 to workstations 19 to 37.

How would you do that?

Thanks

 

[Logit]

There are better ways of doing this but for a quick fix/answer :

Sub PickNamesAtRandom()

Dim HowMany As Integer
Dim NoOfNames As Long
Dim RandomNumber As Integer
Dim Names() As String 'Array to store randomly selected names
Dim i As Byte
Dim CellsOut As Long 'Variable to be used when entering names onto worksheet
Dim ArI As Byte 'Variable to increment through array indexes

Application.ScreenUpdating = False

HowMany = Range("D3").Value
CellsOut = 6

ReDim Names(1 To HowMany) 'Set the array size to how many names required
NoOfNames = Application.CountA(Range("A:A")) - 1 ' Find how many names in the list
i = 1

Do While i <= HowMany
RandomNo:
    RandomNumber = Application.RandBetween(2, NoOfNames + 1)
    'Check to see if the name has already been picked
    For ArI = LBound(Names) To UBound(Names)
        If Names(ArI) = Cells(RandomNumber, 1).Value Then
            GoTo RandomNo
        End If
    Next ArI
    Names(i) = Cells(RandomNumber, 1).Value ' Assign random name to the array
    i = i + 1
Loop

'Loop through the array and enter names onto the worksheet
For ArI = LBound(Names) To UBound(Names)

    Cells(CellsOut, 4) = Names(ArI)
    CellsOut = CellsOut + 1

Next ArI

Application.ScreenUpdating = True

PickNamesAtRandom2

End Sub

Sub PickNamesAtRandom2()

Dim HowMany As Integer
Dim NoOfNames As Long
Dim RandomNumber As Integer
Dim Names() As String 'Array to store randomly selected names
Dim i As Byte
Dim CellsOut As Long 'Variable to be used when entering names onto worksheet
Dim ArI As Byte 'Variable to increment through array indexes
Application.ScreenUpdating = False

HowMany = Range("G3").Value
CellsOut = 6

ReDim Names(1 To HowMany) 'Set the array size to how many names required
NoOfNames = Application.CountA(Range("B:B")) - 1 ' Find how many names in the list
i = 1

Do While i <= HowMany
RandomNo:
    RandomNumber = Application.RandBetween(2, NoOfNames + 1)
    'Check to see if the name has already been picked
    For ArI = LBound(Names) To UBound(Names)
        If Names(ArI) = Cells(RandomNumber, 2).Value Then
            GoTo RandomNo
        End If
    Next ArI
    Names(i) = Cells(RandomNumber, 2).Value ' Assign random name to the array
    i = i + 1
Loop

'Loop through the array and enter names onto the worksheet
For ArI = LBound(Names) To UBound(Names)

    Cells(CellsOut, 7) = Names(ArI)
    CellsOut = CellsOut + 1

Next ArI

Application.ScreenUpdating = True

End Sub

 

[Fluff]

Cross-posting (posting the same question in more than one forum) is not against our rules, but the method of doing so is covered by #13 of the Forum Rules.

Be sure to follow & read the link at the end of the rule too!

Cross posted at: Random assignment
If you have posted the question at more places, please provide links to those as well.

If you do cross-post in the future and also provide links, then there shouldn’t be a problem.

 

[JeanRene]

@Fluff: My apologies for this, I'll make sure to follow the guidelines next time.

@Logit: Thank you very much for your answer. It was more complicated than what I was looking for, but I was able to modify the code to make it work exactly as I was expected!

 

[Logit]

Glad it helped.

Would like to see your version posted here for the benefit of others.

 

[JeanRene]

Of course, here it is. I added values from 1 to x in a column L, and it will assign randomly these values to my the workers, instead of assigning randomly names. As Each value is linked to a workstation, all my workers are then randomly assigned to a workstation,

Sub PickNamesAtRandom()

Dim HowMany As Integer
Dim NoOfNames As Long
Dim RandomNumber As Integer
Dim Names() As String 'Array to store randomly selected names
Dim i As Byte
Dim CellsOut As Long 'Variable to be used when entering names onto worksheet
Dim ArI As Byte 'Variable to increment through array indexes

Application.ScreenUpdating = False

HowMany = Range("G4").Value
CellsOut = 3

ReDim Names(1 To HowMany) 'Set the array size to how many names required

NoOfNames = Range("G4").Value ' How many in team
i = 1

Do While i <= HowMany
RandomNo:
    RandomNumber = Application.RandBetween(1, NoOfNames)
    'Check to see if the name has already been picked
    For ArI = LBound(Names) To UBound(Names)
        If Names(ArI) = Cells(RandomNumber, 12).Value Then  'go take cell value in column L
            GoTo RandomNo
        End If
    Next ArI
    Names(i) = Cells(RandomNumber, 12).Value ' Assign random name to the array
    i = i + 1
Loop

'Loop through the array and enter names onto the worksheet
For ArI = LBound(Names) To UBound(Names)

    Cells(CellsOut, 4) = Names(ArI)
    CellsOut = CellsOut + 1

Next ArI

Application.ScreenUpdating = True

PickNamesAtRandom2

End Sub

Sub PickNamesAtRandom2()

Dim HowMany As Integer
Dim NoTeam1 As Integer 'No of worker in team 1
Dim NoTeam2 As Integer 'No of worker in team 2
Dim NoOfNames As Long
Dim RandomNumber As Integer
Dim Names() As String 'Array to store randomly selected names
Dim i As Byte
Dim CellsOut As Long 'Variable to be used when entering names onto worksheet
Dim ArI As Byte 'Variable to increment through array indexes

Application.ScreenUpdating = False

HowMany = Range("G5").Value
NoTeam1 = Range("G4").Value
NoTeam2 = Range("G5").Value
CellsOut = 3 + NoTeam1

ReDim Names(1 To HowMany) 'Set the array size to how many names required

NoOfNames = Range("G5").Value ' How many in team
i = 1

Do While i <= HowMany
RandomNo:
    RandomNumber = Application.RandBetween(NoTeam1 + 1, NoTeam1 + NoTeam2)
    'Check to see if the name has already been picked
    For ArI = LBound(Names) To UBound(Names)
        If Names(ArI) = Cells(RandomNumber, 12).Value Then  'go take cell value in column L
            GoTo RandomNo
        End If
    Next ArI
    Names(i) = Cells(RandomNumber, 12).Value ' Assign random name to the array
    i = i + 1
Loop

'Loop through the array and enter names onto the worksheet
For ArI = LBound(Names) To UBound(Names)

    Cells(CellsOut, 4) = Names(ArI)
    CellsOut = CellsOut + 1

Next ArI

Application.ScreenUpdating = True

'PickNamesAtRandom2

End Sub