Sign up to receive Decoded, a new monthly digest with product updates, feature release info, continuing education opportunities, and more.
Public Sub GetRandomWorkDistribution()
' I'm hardcoding the inputs but you may want to extract them from the worksheet
Dim hoursPerDay As Decimal = 8D
Dim daysPerPeriod As Integer = 10
Dim totalHours As Decimal = hoursPerDay * daysPerPeriod
Dim minimumTimeUnit As Decimal = 0.1D
Dim percentAllocations As New Dictionary(Of Integer, Decimal)() _
From {{1, 30D}, {2, 15D}, {3, 20D}, {4, 25D}, {5, 10D}}
' Calculate the actual allocations to the near unit
' ...and add the balance of time lost/gained from rounding to project 1
Dim actualAllocations As IDictionary(Of Integer, Decimal) = _
percentAllocations.ToDictionary(Function(kvp) kvp.Key, _
Function(kvp) Math.Round(kvp.Value * totalHours / 100 / minimumTimeUnit) * minimumTimeUnit)
Dim allocationRoundingError As Decimal = totalHours - actualAllocations.Values.Sum()
actualAllocations(1) = actualAllocations(1) + allocationRoundingError
' Find out up front which projects actually have work
Dim projectsWithWork As IEnumerable(Of Integer) = actualAllocations.Where(Function(kvp) kvp.Value > 0).Select(Function(kvp) kvp.Key)
' Setup the original base case
' -> First integer represents the project ID, second is the day ID, the double is the number of hours
Dim workDistribution As New Dictionary(Of Integer, IDictionary(Of Integer, Decimal))()
For Each project As Integer In actualAllocations.Keys
' Calculate the total time allocated to the project
' ...and add the balance of time lost/gained to the first day
Dim projectAllocation As Decimal = actualAllocations(project)
Dim perDayAllocation As Decimal = Math.Round(projectAllocation / daysPerPeriod / minimumTimeUnit) * minimumTimeUnit
Dim perDayRoundingError As Decimal = projectAllocation - (perDayAllocation * daysPerPeriod)
' Create a dictionary for the period
Dim days As New Dictionary(Of Integer, Decimal)(daysPerPeriod)
days(1) = perDayAllocation + perDayRoundingError
For d As Integer = 2 To daysPerPeriod
days(d) = perDayAllocation
Next
workDistribution(project) = days
Next
' Apply trades
Dim rand As New Random()
For i As Integer = 0 To 10000
' Randomly select projects
Dim donorProject As Integer = projectsWithWork.ElementAt(rand.Next(0, projectsWithWork.Count))
Dim receiverProject As Integer = projectsWithWork.ElementAt(rand.Next(0, projectsWithWork.Count))
' Get days with work allocated
' ...and skip if none available
Dim donorDays As IEnumerable(Of Integer) = workDistribution(donorProject).Where(Function(kvp) kvp.Value > 0).Select(Function(kvp) kvp.Key)
Dim receiverDays As IEnumerable(Of Integer) = workDistribution(receiverProject).Where(Function(kvp) kvp.Value > 0).Select(Function(kvp) kvp.Key)
If donorDays.Count = 0 OrElse receiverDays.Count = 0 Then Continue For
' Randomly select days
Dim donorDay As Integer = donorDays.ElementAt(rand.Next(0, donorDays.Count))
Dim receiverDay As Integer = receiverDays.ElementAt(rand.Next(0, receiverDays.Count))
' Trade
Dim donorDistribution As IDictionary(Of Integer, Decimal) = workDistribution(donorProject)
Dim receiverDistribution As IDictionary(Of Integer, Decimal) = workDistribution(receiverProject)
donorDistribution(donorDay) = donorDistribution(donorDay) - minimumTimeUnit
donorDistribution(receiverDay) = donorDistribution(receiverDay) + minimumTimeUnit
receiverDistribution(donorDay) = receiverDistribution(donorDay) + minimumTimeUnit
receiverDistribution(receiverDay) = receiverDistribution(receiverDay) - minimumTimeUnit
Next
' Do something to write the results back to the worksheet
' -> I'm just printing to the console
For Each project As Integer In workDistribution.Keys
Dim line As New System.Text.StringBuilder()
line.Append(project.ToString()).Append(vbTab)
Dim projectDistribution As IDictionary(Of Integer, Decimal) = workDistribution(project)
For Each day As Integer In projectDistribution.Keys
line.Append(projectDistribution(day)).Append(vbTab)
Next
Console.WriteLine(line.ToString())
Next
End Sub
Public Sub GetRandomWorkDistribution()
' I'm hardcoding the inputs but you may want to extract them from the worksheet
Dim daysPerPeriod As Integer, hoursPerDay, totalHours, minimumTimeUnit As Variant
hoursPerDay = CDec(8)
daysPerPeriod = CDec(10)
totalHours = hoursPerDay * daysPerPeriod
minimumTimeUnit = CDec(0.1)
MsgBox (daysPerPeriod)
End Sub
Public Sub GetRandomWorkDistribution()
' I'm hardcoding the inputs but you may want to extract them from the worksheet
Dim daysPerPeriod As Integer, hoursPerDay, totalHours, minimumTimeUnit As Variant
hoursPerDay = CDec(8)
daysPerPeriod = CDec(10)
totalHours = hoursPerDay * daysPerPeriod
minimumTimeUnit = CDec(0.1)
Dim percentAllocations As New Scripting.Dictionary
percentAllocations.Add 1, CDec(30)
percentAllocations.Add 2, CDec(15)
percentAllocations.Add 3, CDec(20)
percentAllocations.Add 4, CDec(25)
percentAllocations.Add 5, CDec(10)
' Calculate the actual allocations to the near unit
' ...and add the balance of time lost/gained from rounding to project 1
Dim actualAllocations As New Scripting.Dictionary
For Each pKey In percentAllocations.Keys
actualAllocations.Add pKey, Round((percentAllocations.Item(pKey) * totalHours / 100 / minimumTimeUnit) * minimumTimeUnit)
Next
Dim allocationsRoundingError As Variant
allocationsRoundError = totalHours
For Each aKey In actualAllocations.Keys
allocationsRoundError = allocationsRoundError - actualAllocations(aKey)
Next
actualAllocations.Items(0) = actualAllocations.Items(0) + allocationsRoundingError
' Dump it back out to show where we are...
Dim temp As String
For Each aKey In actualAllocations.Keys
temp = temp & aKey & "-" & actualAllocations.Item(aKey) & vbCrLf
Next
MsgBox (temp)
End Sub
' Find out up front which projects actually have work
Dim projectsWithWork As New Collection
For Each aKey In actualAllocations.Keys
If actualAllocations.Item(aKey) > 0 Then projectsWithWork.Add (aKey)
Next
' Dump it back out to show where we are...
Dim temp As String
Dim pIndex As Integer
For pIndex = 1 To projectsWithWork.Count
temp = temp & pIndex & "-" & projectsWithWork.Item(pIndex) & vbCrLf
Next
MsgBox (temp)
' Setup the original base case
' -> First integer represents the project ID, second is the day ID, the double is the number of hours
Dim workDistribution As New Scripting.Dictionary ' Int > (Int > Decimal)
Dim days As Scripting.Dictionary ' Int > Decimal
For Each pKey In actualAllocations.Keys
' Calculate the total time allocated to the project
' ...and add the balance of time lost/gained to the first day
Dim projectAllocation, perDayAllocation, perDayRoundingError As Variant ' Decimal
projectAllocation = actualAllocations(pKey)
perDayAllocation = Round(projectAllocation / daysPerPeriod / minimumTimeUnit) * minimumTimeUnit
perDayRoundingError = projectAllocation - (perDayAllocation * daysPerPeriod)
' Create a dictionary for the period
Set days = New Scripting.Dictionary ' Int > Decimal
days.Add 1, perDayAllocation + perDayRoundingError
Dim dIndex As Integer
For dIndex = 2 To daysPerPeriod
days.Add dIndex, perDayAllocation
Next
workDistribution.Add pKey, days
Next
Private Function RandBetween(lowerbound As Double, upperbound As Double) As Integer
RandBetween = CInt(Int((upperbound - lowerbound + 1) * Rnd())) + lowerbound
End Function
' Apply trades
Dim tIndex, donorProject, receiverProject, donorDay, receiverDay As Integer
Dim projectDistribution As Scripting.Dictionary
Dim donorDays, receiverDays As Collection
For tIndex = 0 To 10000
' Randomly select projects
donorProject = projectsWithWork.Item(RandBetween(1, projectsWithWork.Count))
receiverProject = projectsWithWork.Item(RandBetween(1, projectsWithWork.Count))
' Get days with work allocated
' ...and skip if none available
Set donorDistribution = workDistribution(donorProject)
Set donorDays = New Collection
For Each dKey In donorDistribution.Keys
If donorDistribution(dKey) > 0 Then donorDays.Add dKey
Next
Set receiverDistribution = workDistribution(receiverProject)
Set receiverDays = New Collection
For Each dKey In receiverDistribution.Keys
If receiverDistribution(dKey) > 0 Then receiverDays.Add dKey
Next
If donorDays.Count <> 0 And receiverDays.Count <> 0 Then
' Randomly select days
donorDay = donorDays.Item(RandBetween(1, donorDays.Count))
receiverDay = receiverDays.Item(RandBetween(1, receiverDays.Count))
' Trade
donorDistribution(donorDay) = donorDistribution(donorDay) - minimumTimeUnit
donorDistribution(receiverDay) = donorDistribution(receiverDay) + minimumTimeUnit
receiverDistribution(donorDay) = receiverDistribution(donorDay) + minimumTimeUnit
receiverDistribution(receiverDay) = receiverDistribution(receiverDay) - minimumTimeUnit
End If
Next
' Dump it back out to show where we are...
Dim temp As String
For Each dKey In workDistribution(1)
temp = temp & dKey & "-" & workDistribution(1).Item(dKey) & vbCrLf
Next
MsgBox (temp)
Public Sub GetRandomWorkDistribution()
' I'm hardcoding the inputs but you may want to extract them from the worksheet
Dim daysPerPeriod As Integer, hoursPerDay, totalHours, minimumTimeUnit As Variant
hoursPerDay = CDec(8)
daysPerPeriod = CDec(10)
totalHours = hoursPerDay * daysPerPeriod
minimumTimeUnit = CDec(0.1)
Dim percentAllocations As New Scripting.Dictionary
percentAllocations.Add 1, CDec(30)
percentAllocations.Add 2, CDec(15)
percentAllocations.Add 3, CDec(20)
percentAllocations.Add 4, CDec(25)
percentAllocations.Add 5, CDec(10)
' Calculate the actual allocations to the near unit
' ...and add the balance of time lost/gained from rounding to project 1
Dim actualAllocations As New Scripting.Dictionary
For Each pKey In percentAllocations.Keys
actualAllocations.Add pKey, Round((percentAllocations.Item(pKey) * totalHours / 100 / minimumTimeUnit) * minimumTimeUnit)
Next
Dim allocationsRoundingError As Variant
allocationsRoundError = totalHours
For Each aKey In actualAllocations.Keys
allocationsRoundError = allocationsRoundError - actualAllocations(aKey)
Next
actualAllocations.Items(0) = actualAllocations.Items(0) + allocationsRoundingError
' Find out up front which projects actually have work
Dim projectsWithWork As New Collection
For Each aKey In actualAllocations.Keys
If actualAllocations.Item(aKey) > 0 Then projectsWithWork.Add (aKey)
Next
' Setup the original base case
' -> First integer represents the project ID, second is the day ID, the double is the number of hours
Dim workDistribution As New Scripting.Dictionary ' Int > (Int > Decimal)
Dim days As Scripting.Dictionary ' Int > Decimal
For Each pKey In actualAllocations.Keys
' Calculate the total time allocated to the project
' ...and add the balance of time lost/gained to the first day
Dim projectAllocation, perDayAllocation, perDayRoundingError As Variant ' Decimal
projectAllocation = actualAllocations(pKey)
perDayAllocation = Round(projectAllocation / daysPerPeriod / minimumTimeUnit) * minimumTimeUnit
perDayRoundingError = projectAllocation - (perDayAllocation * daysPerPeriod)
' Create a dictionary for the period
Set days = New Scripting.Dictionary ' Int > Decimal
days.Add 1, perDayAllocation + perDayRoundingError
Dim dIndex As Integer
For dIndex = 2 To daysPerPeriod
days.Add dIndex, perDayAllocation
Next
workDistribution.Add pKey, days
Next
' Apply trades
Dim tIndex, donorProject, receiverProject, donorDay, receiverDay As Integer
Dim projectDistribution As Scripting.Dictionary
Dim donorDays, receiverDays As Collection
For tIndex = 0 To 10000
' Randomly select projects
donorProject = projectsWithWork.Item(RandBetween(1, projectsWithWork.Count))
receiverProject = projectsWithWork.Item(RandBetween(1, projectsWithWork.Count))
' Get days with work allocated
' ...and skip if none available
Set donorDistribution = workDistribution(donorProject)
Set donorDays = New Collection
For Each dKey In donorDistribution.Keys
If donorDistribution(dKey) > 0 Then donorDays.Add dKey
Next
Set receiverDistribution = workDistribution(receiverProject)
Set receiverDays = New Collection
For Each dKey In receiverDistribution.Keys
If receiverDistribution(dKey) > 0 Then receiverDays.Add dKey
Next
If donorDays.Count <> 0 And receiverDays.Count <> 0 Then
' Randomly select days
donorDay = donorDays.Item(RandBetween(1, donorDays.Count))
receiverDay = receiverDays.Item(RandBetween(1, receiverDays.Count))
' Trade
donorDistribution(donorDay) = donorDistribution(donorDay) - minimumTimeUnit
donorDistribution(receiverDay) = donorDistribution(receiverDay) + minimumTimeUnit
receiverDistribution(donorDay) = receiverDistribution(donorDay) + minimumTimeUnit
receiverDistribution(receiverDay) = receiverDistribution(receiverDay) - minimumTimeUnit
End If
Next
' Dump it back out to show where we are...
'Dim temp As String
'For Each dKey In workDistribution(1)
' temp = temp & dKey & "-" & workDistribution(1).Item(dKey) & vbCrLf
'Next
'MsgBox (temp)
' Dump it all out to Excel
Dim xIndex, yIndex As Integer
Dim ws As Worksheet
Set ws = ActiveSheet
yIndex = 1
With ws
' Label the days
For xIndex = 1 To daysPerPeriod
.Cells(1, xIndex + 1).Value = xIndex
Next
For Each pKey In workDistribution
yIndex = yIndex + 1
' Label the projects
.Cells(yIndex, 1).Value = pKey
' Output the distribution
Set projectDistribution = workDistribution(pKey)
For Each dKey In projectDistribution
.Cells(yIndex, dKey + 1).Value = projectDistribution(dKey)
Next
Next
End With
End Sub
Private Function RandBetween(lowerbound As Double, upperbound As Double) As Integer
RandBetween = CInt(Int((upperbound - lowerbound + 1) * Rnd())) + lowerbound
End Function
Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.
Have a better answer? Share it in a comment.
- Create a base case distribution that works for all your rules
- Make random "trades" between the projects that cannot violate the rules
Detailed Explanation
- Work out the expected number of hours to be worked on each project by multiplying the total number of hours by the percentage.
- Fill your 'table' in a completely systematic manner that respects your rules
- Randomly select a pair projects
- Randomly select 2 days
- Trade your minimum time unit (0.1 hours) between them
- Loop !!
Example Base Cases
1) Just assign 1/10 of each project to each day
Example Trade
0.1 hours has been moved from project 1 to project 4 on the first Monday, and in response 0.1 hours has been moved the opposite direction the following Tuesday.
I considered trading random amounts but I think this might skew towards extremes e.g. 0 or 8 hours allocated more often than middle values. Plus it's easier to always trade the minimum unit and just run the loop a huge number of times.
Filtering Out Invalid Trades
If the you cannot find a day (because one project only has work to send where the other is already maxed then just discard the result and continue with the loop
If you happen to select the same day as both donor and receiver day then it actually doesn't matter (the trade will work although in practice results in no change)
Pseudo Code
... tbd ...
Aside
I love trying to solve problems using raw Excel and sneaky formulas. I first tried using Excel formulas only but I think this problem may be impossible to solve reliably that way but it was fun to try.