Alright see attachment for an entirely random solution.
It got a bit messy, but the basic principle is this:
Store all days in a collection. Create an array with randomised numbers (1 to count of days) use a loop to select dates randomly using this array's values.
Option Explicit 'Always start your code with this. You have to declare your variables with DIM and REDIM statements, making the code more robust.
'Automatic Shift Scheduler. Coded by: Tuomas "banaanas" Savonius
'User needs to input variables on worksheet for the code to work properly!
Sub DoShifts()
Application.ScreenUpdating = False 'Disable screenupdates for faster code execution
Dim wb As Workbook 'ThisWorkbook
Dim ws As Worksheet 'Our Month Worksheet
Dim c As Range 'Helper range
Dim lastdate As Range 'Max times cell
Dim PeopleNeed As Range 'People needed cell
Dim Maxtimes As Range 'Max times cell
Dim i As Long 'Helper where we store the amount of people needed that day
Dim j As Long 'Helper where we keep track of the current employer row
Dim timesAv As Long 'Helper where we keep count of the total persons avaivable
Dim cCol As New Collection 'Collection where we will store cell dates
Dim helpArray() As Long 'Helper array to loop collection
Dim k As Long 'Helper to loop collection
Dim l As Long 'Helper to loop collection
'Setting Workbook, worksheet and ranges
Set wb = ThisWorkbook
Set ws = wb.ActiveSheet
Set lastdate = ws.UsedRange.Find(what:="Max times", LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlNext, MatchCase:=False)
Set PeopleNeed = ws.UsedRange.Find(what:="People needed", LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByColumns, searchdirection:=xlNext, MatchCase:=False)
Set Maxtimes = ws.UsedRange.Find(what:="Times available", LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByColumns, searchdirection:=xlNext, MatchCase:=False)
'Setting the avaibable resources
timesAv = ws.UsedRange.Find(what:="Sum of TimesA:", LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlNext, MatchCase:=False).Offset(0, 1).Value
For Each c In ws.Range(ws.Cells(1, 2), lastdate.Offset(0, -1)) 'Loop all cells from B1 to The lastdate cell - 1 column. This way you can have as many days as you want, and the code will work
cCol.Add c 'Add range to collection
Next c 'Move to the next day
helpArray() = randomArr(cCol.Count) 'Create random order array
ReDim Preserve helpArray(1 To cCol.Count) 'Make array as long as the collection
l = 1 'set l to first position
For k = 1 To cCol.Count 'Loop all collections
Set c = cCol(helpArray(l)) 'select a random cell from collection
i = ws.Cells(PeopleNeed.Row, c.Column).Value - ws.Cells(PeopleNeed.Row + 1, c.Column) 'Set i to the amoun needed - amount allredy allocated. This will allow you to set "manually" work days in the sheet and code will still work
j = 2 'Set the first row of the employer
Do While i > 0 And j < PeopleNeed.Row 'Do this loop while we still need people to the day, and our employer row is less than the range where "people needed" is written
If timesAv > 0 Then 'if we still have times avaivable then
If ws.Cells(j, Maxtimes.Column).Value > 0 And ws.Cells(j, c.Column) = vbNullString Then 'If current employer cell is empty, and the employer still have times avaiable
ws.Cells(j, c.Column).Value = "W" 'Write W to cell
timesAv = timesAv - 1 'Reduce times avaivable by 1
i = i - 1 'Remove 1 of the days needed work
j = j + 1 'Add to employer row
Else
j = j + 1 'If for some reason the above will not work, move to next employer
End If
End If
If timesAv = 0 Then 'If there is no avaivable times anymore
Exit Do 'Exit the loop
End If
Loop
l = l + 1 'increase to next array item
Next
Application.ScreenUpdating = True 'Enable screenupdates back on
MsgBox "Done"
End Sub
'Function to generate no duplicate values into an array. Base done by aevenko on stackoverflow
Function randomArr(maxnum As Long)
Dim i As Long, n As Long
Dim numArray(1 To 1000) As Long
Dim numCollection As New Collection
With numCollection
For i = 1 To maxnum
.Add i
Next
For i = 1 To maxnum
n = Rnd * (.Count - 1) + 1
numArray(i) = numCollection(n)
.Remove n
Next
End With
randomArr = numArray()
End Function
LinkBack URL
About LinkBacks
Register To Reply
Originally Posted by ricbrear
Bookmarks