1
\$\begingroup\$

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:

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
\$\endgroup\$

0

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Browse other questions tagged or ask your own question.