VBA assign values to a range in random positions

[Vasilis Ioannidis]

Hello,

I have this problem. With a table like this (75 rows):

[TABLE="width: 500"]
<tbody>[TR]
[TD][/TD]
[TD]Station 1[/TD]
[TD]Station 2[/TD]
[TD]Station 3[/TD]
[TD]Station 4[/TD]
[TD]Station 5[/TD]
[TD]Station 6[/TD]
[/TR]
[TR]
[TD]Person 1[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Person 2[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

I need to assign turns to each person so they can go through all stations. The maximum people per station can be 14 so we need 6 turns. It is important that the order assigned is random. I have developed this macro to help me through which works fine for the first column (I am new in VBA so any suggestion on how to make this code better is more than welcome). My problem is that when I run it for the next columns I don't want to get duplicate values in a row (e.g. Person 1 to have the value "Turn 1" more than once). Do you have any idea how I can make this work?
....................................................................
Sub grouping()


Dim n As Integer, i As Integer, j As Integer, c As Integer, sample As Integer, counter As Integer
Dim indexes As New Collection
Dim rng As Range


c = 2
n = 14
Math.Randomize
For i = 2 To 76
If IsEmpty(Cells(i, c)) Then
indexes.Add (i)
End If
Next i


For j = 1 To 6


counter = 0
While counter < 14 And indexes.Count > 0
sample = Int(Math.Rnd() * indexes.Count + 1)
If IsEmpty(Cells(indexes.Item(sample), c)) Then
Cells(indexes.Item(sample), c).Value = "Turn" & " " & j
indexes.Remove (sample)
counter = counter + 1
Else
indexes.Remove (sample)
End If
Wend
If (counter < 14) Then
MsgBox "Not all positions free"
End If


Next j


End Sub
.......................................................

Thank you!

 

[gallen]

I've tried it but once you get past a certain number of rows it can fail because both criteria equal false:

1)No more than 14 occurrences in a column
2)Unique station number in row.

So though it is possible, doing it random can make it fall over

 

[gallen]

This code works(ish) in that if you run it and it fails, you can clear it down and try again.

Out of 3 goes I got 1 success for a value in each cell.

Best I can do with the criteria...

Sub improved()
Dim stations As New Collection
Dim c As Integer, r As Integer, coll As Integer
Dim tryCount As Integer'count number attempts
Application.ScreenUpdating = False
    
    For r = 2 To 75
    
        With stations
            .Add ("Station 1")
            .Add ("Station 2")
            .Add ("Station 3")
            .Add ("Station 4")
            .Add ("Station 5")
            .Add ("Station 6")
        End With
        
        For c = 2 To 7
        tryCount = 0
TryAgain:
            'only randomize if more than 1 item
            If stations.Count > 1 Then
                coll = Int(Math.Rnd() * stations.Count + 1)
            Else
                coll = 1
            End If
            
            If Application.WorksheetFunction.CountIf(Columns(c), stations.Item(coll)) < 14 Then
                Cells(r, c).Value = stations.Item(coll)
                stations.Remove (coll)
            Else
                'try 10 times to get a value
                If tryCount < 10 Then
                    tryCount = tryCount + 1
                    If stations.Count > 1 Then GoTo TryAgain
                Else
                    'failed to get value
                    Cells(r, c).Value = "Error"
                    tryCount = 0
                End If
            End If
        Next c
    Next r


Application.ScreenUpdating = True


End Sub

 

[Vasilis Ioannidis]

I got it on the second try :P
Failed the rest but it only has to work once, I don't have to present it to anyone so it's fine.

I really appreciate the time and effort you spend on this! Thank you!