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!

 

[Vasilis Ioannidis]

Hi!

I have completely changed the way this macro works. In order to avoid duplicates I put it to first fill the columns of a row and then proceed to the next row and it works sweet!
..........................................
Sub improved()
Dim stations As New Collection
Dim c As Integer, r As Integer, coll As Integer

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
coll = Int(Math.Rnd() * stations.Count + 1)
Cells(r, c).Value = stations.Item(coll)
stations.Remove (coll)
Next c
Next r

Application.ScreenUpdating = True

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

My question now is how could I restrict it to not take the same value more than 14 times inside each column?

Would be really thankful for a response!

 

[gallen]

If I've understood you correctly:

Sub improved()
Dim stations As New Collection
Dim c As Integer, r As Integer, coll As Integer


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
            coll = Int(Math.Rnd() * stations.Count + 1)
            [B][COLOR=#ff0000]If Application.WorksheetFunction.CountIf(Columns(c), stations.Item(coll)) < 14 Then[/COLOR][/B]
                Cells(r, c).Value = stations.Item(coll)
                stations.Remove (coll)
           [COLOR=#ff0000][B] End If[/B][/COLOR]
        Next c
    Next r


Application.ScreenUpdating = True


End Sub

 

[Vasilis Ioannidis]

Yes!!

Works perfectly, thank you!

 

[gallen]

Your'e welcome. Good luck with what on earth it is you are trying to achieve

 

[Vasilis Ioannidis]

Haha it's actually just splitting a group of people for team building activities. The "Stations" are the different activities that will be taking place at the same time, so after each activity ends there will be a rotation so all people will go through all of the activities. The "catch" is that we don't want to have stable groups in order for a person to interact with as many other people as possible, that's why I needed to randomize the order. And 14 is the maximum number of people that can attend an activity at once

 

[Vasilis Ioannidis]

Actually, after I tested it some times, with the "if" used it now takes duplicate values in rows. Can we fix that somehow?

I thought about applying instead a "Do Until Application.WorksheetFunction.Max (range("B2:G76")) = 14" rule in the beginning but it just goes into an infinite loop.

 

[Vasilis Ioannidis]

EDIT: It took duplicates because I run it twice.. But the real issue is that it leaves blank cells when the "if" is false. This is what we have to correct

 

[gallen]

Yes I saw that, but you need to say what you would like if we have hit 14, do you need to find one that is less than 14?

 

[Vasilis Ioannidis]

I'm not quite sure what we could put on the "else" here to make it work. Maybe if it leaves a cell empty in a row to recalculate the whole row until it fills all the cells with values that fit the criteria. Still, there is the possibility to reach a dead end combination this way but with a little luck it could work.

I know that statistically speaking there is a combination that fits the criteria for both the rows and the columns but i don't know how to reach that combination. This is what I tried to achieve using the "Do..Until" mentioned above, eventually hit this combination, but I guess it was too much for excel to handle.