VBA to calculate when production will finish - vba

Question

I am trying build a macro to give me the date and time production will end based on a value entered into cell A2. At present each unit takes 1 min 5 sec to produce. the shift will finish at 00:30 and restart at 05:30 so I would like it to take this into consideration.
Some examples
If the date/time is 14/03/2017 22:00 and I enter 55 into cell A2 I would expect a return of 14/03/2017 23:00 in cell E2.
If the date/time is 14/03/2017 22:00 and I entered 1 into cell A2 I would expect a return of 14/03/2017 22:01 in cell E2.
If the time is 14/03/2017 23:55 and I entered 55 into cell A2 I would expect a return of 15/03/2017 05:55
So at the moment I am using this code which works well within the shift but I cant get any further with it ie. going into the next days production.
Range("A2").Value * Range("C2").Value + Now()
A2 being the number of units and C2 being the process time 0,1,5
Many thanks for your help /advice

Answer 1

I'm not sure what the problem is. The maths are (units * time-per-unit) + start time. The brackets are for visual clrity only; mathematical precedence will ensure that the multiplication takes place before the addition.
With Worksheets("sheet1")
.Range("E2") = Now
.Range("F2") = .Range("E2").Value2 + (.Range("A2").Value2 * .Range("C2").Value2)
.Range("G2") = Application.Ceiling(.Range("F2").Value2, TimeSerial(0, 0, 1))
.Range("E2:G2").NumberFormat = "[Color10][$-en-US]dd-mmm-yyyy hh:mm;[Color3]#"
End With
FWIW, I've had better success using .Value2 instead of .Value as it is a raw numerical without additional date/time/currency information.

Answer 2

This took a little time but it turned out rather nice. Follow these instructions to test.
Create a standard code module in the workbook in which you want the action to occur. The name will be "Module1" by default. I suggest you change it to "Main" or some better, descriptive name. Paste the following enumerations at the top of your module, including the option statement.
Option Explicit
Enum Nws ' Worksheet navigation
NwsFirstDataRow = 2
NwsQty = 1 ' Columns (not necessarily contiguous):
NwsTime ' time to produce one unit
NwsStart ' date/time
NwsEnd ' date/time
End Enum
This enumeration serves to identify rows and columns in your worksheet. Note that columns are numbered (1=A, 2=B, 3=C etc.) Enumerations without a value assume the value of the previous one +1. So, NwsEnd = 4 = column D. You can set up the sheet according to the enum or adjust the enum values to match your sheet, but you must have a column for each of Quantity, Production time, Production Start time, and Production completion time. NwsFirstDataRow serves to prevent the macro from changing data you don't want changed - at least those in the caption row, here presumed to be row 1.
Now past the next enumeration below the above.
Enum Nsh ' Shift (use 24h format)
NshStart = 530 ' read as 05:30 (on current day)
NshEnd = 2430 ' read as 00:30 (on next day)
End Enum
This enum holds a code for your shift time. In the future, if your working hours change, you can modify the code's output simply by changing these numbers.
The next sub is doing most of the work.
Sub SetCompletion(Ws As Worksheet, R As Long)
' 20 Mar 2017
Dim Qty As Long
Dim ShiftQty As Long, DayQty As Long
Dim UnitTime As Double, StartTime As Double
Dim ComplDate As Double
Dim Days As Integer
With Rows(R)
Qty = .Cells(NwsQty).Value
UnitTime = .Cells(NwsTime).Value
StartTime = .Cells(NwsStart).Value
If Qty And (UnitTime > 0) And (StartTime > 0) Then
ComplDate = (UnitTime * Qty) + StartTime
ShiftQty = QtyTillShiftEnd(StartTime, UnitTime)
If ShiftQty < Qty Then
Qty = Qty - ShiftQty
DayQty = DailyProduction(UnitTime)
ComplDate = StartTime + 1 + Int(Qty / DayQty)
ComplDate = ComplDate + UnitTime * (Qty Mod DayQty)
End If
.Cells(NwsEnd).Value = ComplDate
End If
End With
End Sub
Its basic calculation method is to first calculate how many units can be produced from the start of production until the end of that day's shift. Then calculate the full days' production, and calculate the completion from the number of remaining units to be produced on the last day. No such calculation will be made while any of the 3 required components are missing (Qty, Time, StartTime). The following functions are helping in the calculation. Paste them at the bottom of the same "Main" code module.
Private Function QtyTillShiftEnd(ByVal StartTime As Double, _
ByVal UnitTime As Double) As Double
' 20 Mar 2017
Dim ProdTime As Double
ProdTime = (Int(StartTime) + NshToDays(NshEnd) - StartTime)
QtyTillShiftEnd = (ProdTime + 0.0001) / UnitTime
End Function
Calculates the quantity that can be produced from the start time until the end of the first production day's shift. The next function calculates a full day's production.
Private Function DailyProduction(UnitTime As Double) As Integer
' 19 Mar 2017
DailyProduction = Int((NshToDays(NshEnd) - NshToDays(NshStart) + 0.000001) / UnitTime)
End Function
When working with Double type numbers, required for time calculations, VB has difficulty calculating zero. The 0.000001 added to the result ensures that the calculation doesn't end up below zero when zero is required. The next function converts the encoded shift times from Enum Nsh into fractions of days which this program can work with.
Private Function NshToDays(TimeCode As Nsh) As Double
' 19 Mar 2017
Dim H As Double, M As Double
H = Int(TimeCode / 100)
M = TimeCode Mod 100
NshToDays = (1 / 24 * H) + (1 / 24 / 60 * M)
End Function
The next function corrects wrong entries in the StartTime column NwsStart.
Function AdjustedStartTime(ByVal StartTime As Double) As Double
' 19 Mar 2017
' return new StartTime or 0
Dim Fun As Double
Dim StartDate As Long
Dim ShiftStart As Double, ShiftEnd As Double
ShiftStart = NshToDays(NshStart)
ShiftEnd = NshToDays(NshEnd)
StartDate = Int(StartTime)
StartTime = StartTime - StartDate
Fun = StartTime
If ShiftEnd > 1 Then
If StartTime < (ShiftStart - Int(ShiftStart)) Then
If StartTime > (ShiftEnd - Int(ShiftEnd)) Then Fun = ShiftStart
End If
Else
If (StartTime - Int(StartTime)) < ShiftStart Then
Fun = ShiftStart
Else
If StartTime > ShiftEnd Then Fun = ShiftStart + 1
End If
End If
AdjustedStartTime = Fun + StartDate
End Function
This function's action is to make sure that no one enters a time like 4:00 am. If someone does the entry will be changed to 05:30 because that's when the shift starts.
The last procedure in this code sheet formats cells.
Sub FormatCells(Row As Range)
' 19 Mar 2017
Dim Fmt As Variant, Clm As Variant
Dim i As Integer
' match for number formats in 'Fmt' to the column numbers in 'Clm'
Clm = Array(NwsQty, NwsTime, NwsStart, NwsEnd)
Fmt = Array("#,##0", "hh:mm:ss", "dd mmm hh:mm", "dd mmm hh:mm")
For i = 0 To UBound(Clm)
Row.Cells(Clm(i)).NumberFormat = Fmt(i)
Next i
End Sub
This sub will be called whenever a production quantity is entered. You can adjust the cell formats here. This goes especially for the date formats which I may not have done to your liking.
Now, still in the VBE window, please find the code sheet for the worksheet on which you have the columns first above enumerated. It might be listed in the Project window as Sheet1(Sheet1) or similar. It is important that you identify the correct sheet and paste the following procedure there.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
' 20 Mar 2017
Dim Entry As Variant
With Target
' no action when more than one cell is modified at once
If .Cells.Count = 1 And .Row >= NwsFirstDataRow Then
Application.EnableEvents = False
Entry = .Value
Select Case .Column
Case NwsQty
If Val(Entry) < 1 Then
If Len(Entry) > 0 Then
MsgBox "Please enter a number representing" & vbCr & _
"the quantity to be produced.", vbExclamation, _
"Invalid entry"
.Select
End If
Else
FormatCells Rows(.Row)
SetCompletion ActiveSheet, .Row
End If
Case NwsTime
If Val(Entry) Then
SetCompletion ActiveSheet, .Row
Else
If Len(Entry) > 0 Then
MsgBox "The production time must be entered" & vbCr & _
"in the format h:m:s", vbExclamation, _
"Invalid entry"
.Select
End If
End If
Case NwsStart
If Val(Entry) Then
If (Val(Entry) < 1) Then .Value = Entry + Date
Entry = AdjustedStartTime(.Value)
If .Value <> Entry Then
MsgBox "On " & Format(Entry, "mmm d") & " production doesn't " & _
"start until " & Format(Entry, "h:mm") & "." & vbCr & _
"Your entry was adjusted accordingly.", _
vbInformation, "Corrected time entry"
.Value = Entry
End If
SetCompletion ActiveSheet, .Row
Else
MsgBox "The production start must be entered as a Time" & vbCr & _
"or Dtae/Time value in the format [d/m/yy] HH:mm", _
vbExclamation, "Invalid entry"
.Select
End If
Case NwsEnd
MsgBox "Recalculate with a new production start?" & vbCr & _
"The completion date is the result of a calculation." & vbCr & _
"To change it, modify the unit production time.", _
vbInformation, "Invalid action"
Application.Undo
End Select
Application.EnableEvents = True
End If
End With
End Sub
You can get a fair idea of what this procedure does by reading the various error messages it can spit out. You can modify these texts. Note that you can enter the start time as a time or Date/Time. If you enter time only the macro will add the current date automatically. In the absence of errors this macro will call the sub SetCompletion which will write the completion date to the sheet if all criteria for its calculation are present.
Note that there is no protection of your data after change of Enum Nsh. To avoid overwriting existing completion dates which were calculated with previously correct shift times, set the enumeration NwsFirstDataRow to exclude rows you wish to protect in this way.
All components have been tested, but the project as a whole is rather complex and you would do well to watch the results in real life. You may have noticed that I have structured the code in such a way that faults can easily be attributed to specific functions which may then have to be improved without putting everything into question.

Answer 3

The problem is with the date format, more specifically, the input date format in the start time column. The macro will only calculate if a start time is given. So, when the start time is given but not recognised as such no calculation takes place.
I programmed for day/month/year and you are using the American system. Please replace the existing procedure of the same name with this one.
Sub FormatCells(Row As Range)
' 25 Mar 2017
Dim Fmt As Variant, Clm As Variant
Dim i As Integer
' match for number formats in 'Fmt' to the column numbers in 'Clm'
Clm = Array(NwsQty, NwsTime, NwsStart, NwsEnd)
Fmt = Array("#,##0", "hh:mm:ss", "mmm dd hh:mm", "mmm dd hh:mm")
For i = 0 To UBound(Clm)
Row.Cells(Clm(i)).NumberFormat = Fmt(i)
Next i
End Sub
Modifications have also been made to the event procedure which will now recognise dates entered in your format. Please remember that you are supposed to be able to enter the start time as 7:30 and have the cell display Mar 25 07:30. Try this. also try entering "Mar 20 7:30", "3/20/17 7:30", "3/20 7:30", and then "3/20/17 14:00" and perhaps "3/20/17 2:00 PM". If it doesn't work that would be indication of bigger wrongs behind the scenes.
Private Sub Worksheet_Change(ByVal Target As Range)
' 25 Mar 2017
Dim Entry As Variant
With Target
' no action when more than one cell is modified at once
If .Cells.Count = 1 And .Row >= NwsFirstDataRow Then
Application.EnableEvents = False
Entry = .Value
Select Case .Column
Case NwsQty
If Val(Entry) < 1 Then
If Len(Entry) > 0 Then
MsgBox "Please enter a number representing" & vbCr & _
"the quantity to be produced.", vbExclamation, _
"Invalid entry"
.Select
End If
Else
FormatCells Rows(.Row)
SetCompletion ActiveSheet, .Row
End If
Case NwsTime
If Val(Entry) Then
SetCompletion ActiveSheet, .Row
Else
If Len(Entry) > 0 Then
MsgBox "The production time must be entered" & vbCr & _
"in the format h:m:s", vbExclamation, _
"Invalid entry"
.Select
End If
End If
Case NwsStart
If IsDate(Entry) Then
If (CDbl(Entry) < 1) Then .Value = Entry + Date
Entry = AdjustedStartTime(.Value)
If .Value <> Entry Then
MsgBox "On " & Format(Entry, "mmm d") & " production doesn't " & _
"start until " & Format(Entry, "h:mm") & "." & vbCr & _
"Your entry was adjusted accordingly.", _
vbInformation, "Corrected time entry"
.Value = Entry
End If
SetCompletion ActiveSheet, .Row
Else
MsgBox "The production start must be entered as a Time" & vbCr & _
"or Date/Time value in the format [m/d/yy] HH:mm", _
vbExclamation, "Invalid entry"
.Select
End If
Case NwsEnd
MsgBox "Recalculate with a new production start?" & vbCr & _
"The completion date is the result of a calculation." & vbCr & _
"To change it, modify the unit production time.", _
vbInformation, "Invalid action"
Application.Undo
End Select
Application.EnableEvents = True
End If
End With
End Sub
Last but not least, I discovered an error in the calculation of the completion time affecting production time ending not on the same day. I corrected it. Please exchange the functions.
Sub SetCompletion(ws As Worksheet, R As Long)
' 25 Mar 2017
Dim Qty As Long
Dim ShiftQty As Long, DayQty As Long
Dim UnitTime As Double, StartTime As Double
Dim ComplDate As Double
Dim Days As Integer
With Rows(R)
Qty = .Cells(NwsQty).Value
UnitTime = .Cells(NwsTime).Value
StartTime = .Cells(NwsStart).Value
If Qty And (UnitTime > 0) And (StartTime > 0) Then
ComplDate = (UnitTime * Qty) + StartTime
ShiftQty = QtyTillShiftEnd(StartTime, UnitTime)
If ShiftQty < Qty Then
Qty = Qty - ShiftQty
DayQty = DailyProduction(UnitTime)
ComplDate = Int(StartTime) + 1 + NshToDays(NshStart) + Int(Qty / DayQty)
ComplDate = ComplDate + UnitTime * (Qty Mod DayQty)
End If
.Cells(NwsEnd).Value = ComplDate
End If
End With
End Sub
Actually, this procedure should be further amended to recognise weekends, but I hope that your production wouldn't stop on Sundays :-)
I shall appreciate your bearing with me in case you still face a problem with the dates. I could change the default settings on my PC for better testing, but so far I have avoided doing so. :-)

Answer 4

The text in your event procedure should be changed in the light of changes you want to make to the code. Please replace as follows:-
MsgBox "You entered a time during which production rests." & vbCr & _
"The next shift after that will start on " & _
Format(Entry, "dddd,") & vbCr & _
Format(Entry, "mmmm d,") & " at " & _
Format(Entry, "h:mm") & "." & vbCr & _
"Your entry was adjusted accordingly.", _
vbInformation, "Corrected time entry"
' MsgBox "On " & Format(Entry, "mmm d") & " production doesn't " & _
' "start until " & Format(Entry, "h:mm") & "." & vbCr & _
' "Your entry was adjusted accordingly.", _
' vbInformation, "Corrected time entry"
Meaning, look for the lines of code with apostrophes at their beginning above and replace them with the liens that don't have an apostrophe.
I suggest you post a link to this thread in the new thread you just started.