# Assign random shift with restrictions

Based on this question

Thought it was a nice puzzle

Main idea: How to randomly assign shifts to employees based on these restrictions:

As per the O.P.:

1. Randomly write to cells "1" or "0"
2. Employees' total shifts in a month can't be more than 7 and less than 4
3. According to a few criteria like "Vacation" or "Definite shift demands"
4. One employee per one day

This is my setup:

Link to current workbook

Note: Open to improvements

Code:

Option Explicit

Sub AssignAllShifts()

Dim targetSheet As Worksheet

Dim availableRange As Range
Dim employeeRange As Range
Dim previousRange As Range
Dim emptyRange As Range

Dim lastRow As Long
Dim counter As Long

Set targetSheet = ThisWorkbook.Worksheets("tablo")

lastRow = targetSheet.Cells(targetSheet.Rows.Count, "A").End(xlUp).Row

' For dev...
targetSheet.Range("B2:AE" & lastRow).ClearContents
targetSheet.Range("C2").Value = "V"
targetSheet.Range("I2").Value = "V"
targetSheet.Range("N2").Value = "V"
targetSheet.Range("D3").Value = "V"
targetSheet.Range("E3").Value = "V"
targetSheet.Range("F4").Value = "V"

For counter = 2 To lastRow

' Get days without shifts assigned
Set availableRange = nonEmptyColsInRange(Range("B2:AE" & lastRow))

Set employeeRange = Intersect(targetSheet.Range("B" & counter & ":AE" & counter), availableRange)

' Init random func
Randomize

AssignShiftsInRange employeeRange

Next counter

End Sub

Private Sub AssignShiftsInRange(ByVal availableRange As Range)

Dim cellAddrArray As Variant
Dim randomCellPos As Variant

Dim totalShifts As Long

Dim counter As Long

' Get random value to assign to employee
totalShifts = Int((7 - 4 + 1) * Rnd + 4)

' Store range cells' addresses in array
cellAddrArray = rangeAddrToArray(availableRange)

' Get x num of cells positions in employe range
randomCellPos = randomNumsToArray(totalShifts, 1, availableRange.Cells.Count)

' Choose x random cells addresses
For counter = 0 To UBound(randomCellPos)

' Assign 1 to cell address
availableRange.Parent.Range(cellAddrArray(randomCellPos(counter))).Value = 1

Next counter

End Sub

Private Function nonEmptyColsInRange(ByVal sourceRange As Range) As Range
Dim column As Range
Dim result As Range

For Each column In sourceRange.Columns

If column.SpecialCells(xlCellTypeBlanks).Count = column.Cells.Count Then
If result Is Nothing Then
Set result = column
Else
Set result = Union(result, column)
End If
End If

Next column

Set nonEmptyColsInRange = result

End Function

Private Function rangeAddrToArray(ByVal sourceRange As Range) As Variant

Dim cell As Range
Dim result As Variant
Dim counter As Long

ReDim result(sourceRange.Cells.Count)

For Each cell In sourceRange.Cells
result(counter) = cell.Address
counter = counter + 1
Next cell

rangeAddrToArray = result

End Function

Private Function randomNumsToArray(ByVal totalNums As Long, ByVal lowerLimit As Long, ByVal upperLimit As Long) As Variant

Dim result As Variant
Dim arrayPosition As Long
Dim randomNum As Long

ReDim result(totalNums - 1)

If totalNums >= upperLimit Then
Err.Raise 5, , "Minimum shifts is greater than available slots"
End If

Do
randomNum = Int((upperLimit - lowerLimit) * Rnd + lowerLimit)
If Not IsNumberInArray(randomNum, result) Then
result(arrayPosition) = randomNum
arrayPosition = arrayPosition + 1
End If
Loop While arrayPosition <= UBound(result)

randomNumsToArray = result

End Function

Private Function IsNumberInArray(ByVal randomNumber As Long, ByVal targetArray As Variant) As Boolean

IsNumberInArray = Not IsError(Application.Match(randomNumber, targetArray, 0))

End Function