So, I've got most things working and while my code is highly inefficient, that is not my concern at the moment. I'm quite new to this vba stuff and need it for some school project.
Everything works as it should till the red dotted line. I can't do what I want to after that. I want to calculate the optimal reward. So basically, it should calculate an optimal reward which has a fixed number of NrDoctorsPermanent for every hour n (but it can be any number), because they work in shifts. The code now kind of recalculates a new number every hour, but that is not possible in my case. Hourly staff can also be hired (NrDoctorsHourly) and the two together should produce an optimal outcome. Determining the optimal amount of permanent and hourly staff seperately isn't hard, but I cannot combine this. It is probably easy to fix, but how do I do it? Thanks for your help already!
The code look as follows:
Option Explicit Dim n As Integer Dim x As Integer Dim MeanNrPatients() As Integer Dim NrDoctorsHourly As Integer Dim NrDoctorsPermanent As Integer Dim NrInWaitingRoom() As Integer Dim Reward() As Double Dim Shift1() As Double Dim Shift2() As Double Dim Shift3() As Double Dim Optimalshift1 As Double Dim Optimalshift2 As Double Dim Optimalshift3 As Double Dim Optimalreward() As Double Dim Optimalhour() As Double Sub Case_3_New() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual ReDim MeanNrPatients(0 To 21) As Integer ReDim Reward(0 To 21, 0 To 120, 0 To 120) As Double ReDim Shift1(0 To 121) ReDim Shift2(0 To 121) ReDim Shift3(0 To 121) ReDim Optimalreward(n To 21, 0 To 120) ReDim NrInWaitingRoom(0 To 50) As Integer ReDim Optimalhour(0 To 21, 0 To 120) As Double For NrDoctorsPermanent = 0 To 120 Optimalreward(21, NrDoctorsPermanent) = 0 Next NrDoctorsPermanent MeanNrPatients(0) = 0 MeanNrPatients(1) = 69 MeanNrPatients(2) = 71 MeanNrPatients(3) = 72 MeanNrPatients(4) = 73 MeanNrPatients(5) = 154 MeanNrPatients(6) = 146 MeanNrPatients(7) = 164 MeanNrPatients(8) = 155 MeanNrPatients(9) = 146 MeanNrPatients(10) = 179 MeanNrPatients(11) = 175 MeanNrPatients(12) = 173 MeanNrPatients(13) = 170 MeanNrPatients(14) = 159 MeanNrPatients(15) = 107 MeanNrPatients(16) = 94 MeanNrPatients(17) = 94 MeanNrPatients(18) = 91 MeanNrPatients(19) = 81 MeanNrPatients(20) = 53 MeanNrPatients(21) = 0 'calculate all possible rewards for every hour For NrDoctorsPermanent = 0 To 120 For NrDoctorsHourly = 0 To 120 - NrDoctorsPermanent For n = 1 To 7 If n <= 5 Then NrInWaitingRoom(n) = WorksheetFunction.Max(0, WorksheetFunction.Min(50, NrInWaitingRoom(n - 1) + MeanNrPatients(n) - 2 * (NrDoctorsPermanent + NrDoctorsHourly))) Reward(n, NrDoctorsHourly, NrDoctorsPermanent) = 80 * NrDoctorsHourly + 325 / 7 * NrDoctorsPermanent + 150 * NrInWaitingRoom(n) + 800 * WorksheetFunction.Max(0, NrInWaitingRoom(n) + MeanNrPatients(n) - 2 * (NrDoctorsPermanent + NrDoctorsHourly) - 50) Else NrInWaitingRoom(n) = WorksheetFunction.Max(0, WorksheetFunction.Min(50, NrInWaitingRoom(n - 1) + MeanNrPatients(n) - 2 * (NrDoctorsPermanent + NrDoctorsHourly))) Reward(n, NrDoctorsHourly, NrDoctorsPermanent) = 60 * NrDoctorsHourly + 325 / 7 * NrDoctorsPermanent + 150 * NrInWaitingRoom(n) + 800 * WorksheetFunction.Max(0, NrInWaitingRoom(n) + MeanNrPatients(n) - 2 * (NrDoctorsPermanent + NrDoctorsHourly) - 50) End If Next n For n = 8 To 14 NrInWaitingRoom(n) = WorksheetFunction.Max(0, WorksheetFunction.Min(50, NrInWaitingRoom(n - 1) + MeanNrPatients(n) - 2 * (NrDoctorsPermanent + NrDoctorsHourly))) Reward(n, NrDoctorsHourly, NrDoctorsPermanent) = 60 * NrDoctorsHourly + 275 / 7 * NrDoctorsPermanent + 150 * NrInWaitingRoom(n) + 800 * WorksheetFunction.Max(0, NrInWaitingRoom(n) + MeanNrPatients(n) - 2 * (NrDoctorsPermanent + NrDoctorsHourly) - 50) Next n For n = 15 To 20 NrInWaitingRoom(n) = WorksheetFunction.Max(0, WorksheetFunction.Min(50, NrInWaitingRoom(n - 1) + MeanNrPatients(n) - 2 * (NrDoctorsPermanent + NrDoctorsHourly))) If n <= 19 Then Reward(n, NrDoctorsHourly, NrDoctorsPermanent) = 80 * NrDoctorsHourly + 300 / 6 * NrDoctorsPermanent + 150 * NrInWaitingRoom(n) + 800 * WorksheetFunction.Max(0, NrInWaitingRoom(n) + MeanNrPatients(n) - 2 * (NrDoctorsPermanent + NrDoctorsHourly) - 50) Else Reward(n, NrDoctorsHourly, NrDoctorsPermanent) = 80 * NrDoctorsHourly + 300 / 6 * NrDoctorsPermanent + 150 * NrInWaitingRoom(n) + 800 * WorksheetFunction.Max(0, NrInWaitingRoom(n) + MeanNrPatients(n) - 2 * (NrDoctorsPermanent + NrDoctorsHourly)) End If Next n Next NrDoctorsHourly Next NrDoctorsPermanent For n = 1 To 20 For NrDoctorsPermanent = 0 To 120 Optimalhour(n, NrDoctorsPermanent) = 1E+15 Next NrDoctorsPermanent Next n ‐---------------------- For NrDoctorsPermanent = 0 To 120 For NrDoctorsHourly = 0 To 120 - NrDoctorsPermanent For n = 20 To 1 Step -1 NrInWaitingRoom(n) = WorksheetFunction.Max(0, WorksheetFunction.Min(50, NrInWaitingRoom(n - 1) + MeanNrPatients(n) - 2 * (NrDoctorsPermanent + NrDoctorsHourly))) If Reward(n, NrDoctorsHourly, NrDoctorsPermanent) + Reward(n + 1, NrDoctorsHourly, NrDoctorsPermanent) < Optimalhour(n, NrDoctorsPermanent) And Reward(n, NrDoctorsHourly, NrDoctorsPermanent) + Reward(n + 1, NrDoctorsHourly, NrDoctorsPermanent) <> 0 Then Optimalhour(n, NrDoctorsPermanent) = Reward(n, NrDoctorsHourly, NrDoctorsPermanent) + Reward(n + 1, NrDoctorsHourly, NrDoctorsPermanent) If Reward(n, NrDoctorsHourly, NrDoctorsPermanent) + Reward(n + 1, NrDoctorsHourly, NrDoctorsPermanent) = Optimalhour(n, NrDoctorsPermanent) Then Optimalreward(n, NrDoctorsPermanent) = Reward(n, NrDoctorsHourly, NrDoctorsPermanent) Next n Next NrDoctorsHourly Shift1(NrDoctorsPermanent) = Optimalreward(1, NrDoctorsPermanent) + Optimalreward(2, NrDoctorsPermanent) + Optimalreward(3, NrDoctorsPermanent) + Optimalreward(4, NrDoctorsPermanent) + Optimalreward(5, NrDoctorsPermanent) + Optimalreward(6, NrDoctorsPermanent) + Optimalreward(7, NrDoctorsPermanent) Shift2(NrDoctorsPermanent) = Optimalreward(8, NrDoctorsPermanent) + Optimalreward(9, NrDoctorsPermanent) + Optimalreward(10, NrDoctorsPermanent) + Optimalreward(11, NrDoctorsPermanent) + Optimalreward(12, NrDoctorsPermanent) + Optimalreward(13, NrDoctorsPermanent) + Optimalreward(14, NrDoctorsPermanent) Shift3(NrDoctorsPermanent) = Optimalreward(20, NrDoctorsPermanent) + Optimalreward(19, NrDoctorsPermanent) + Optimalreward(18, NrDoctorsPermanent) + Optimalreward(17, NrDoctorsPermanent) + Optimalreward(16, NrDoctorsPermanent) + Optimalreward(15, NrDoctorsPermanent) Next NrDoctorsPermanent Shift1(91) = 1E+16 Shift2(91) = 1E+16 Shift3(91) = 1E+16 For NrDoctorsPermanent = 120 To 0 Step -1 If Shift1(NrDoctorsPermanent) < Shift1(NrDoctorsPermanent + 1) Then Optimalshift1 = Shift1(NrDoctorsPermanent) If Shift1(NrDoctorsPermanent) < Shift1(NrDoctorsPermanent + 1) Then Sheets("Sheet1").Cells(15, 2) = NrDoctorsPermanent If Shift2(NrDoctorsPermanent) < Shift2(NrDoctorsPermanent + 1) Then Optimalshift2 = Shift2(NrDoctorsPermanent) If Shift2(NrDoctorsPermanent) < Shift2(NrDoctorsPermanent + 1) Then Sheets("Sheet1").Cells(15, 9) = NrDoctorsPermanent If Shift3(NrDoctorsPermanent) < Shift3(NrDoctorsPermanent + 1) Then Optimalshift3 = Shift3(NrDoctorsPermanent) If Shift3(NrDoctorsPermanent) < Shift3(NrDoctorsPermanent + 1) Then Sheets("Sheet1").Cells(15, 15) = NrDoctorsPermanent Next NrDoctorsPermanent Sheets("Sheet1").Cells(14, 2) = Optimalshift1 Sheets("Sheet1").Cells(14, 9) = Optimalshift2 Sheets("Sheet1").Cells(14, 15) = Optimalshift3 Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub
Reply With Quote
