VBA计算生产何时完成
我试图build立一个macros给我的date和时间生产将基于input到单元格A2的值结束。 目前每个单位需要1分5秒才能生产。 class次将在00:30完成，并在05:30重新开始，所以我希望考虑到这一点。
一些例子
如果date/时间是14/03/2017 22:00，我input55到单元格A2中，我希望在单元格E2中返回14/03/2017 23:00。 如果date/时间是14/03/2017 22:00，我在A2单元格中input1，我希望在单元格E2中返回14/03/2017 22:01。 如果时间是14/03/2017 23:55，我进入55单元A2我期望15/03/2017 05:55返回
所以目前我正在使用这个代码，在转换中运行良好，但我不能得到任何进一步的，即。 进入下一天的生产。 范围（“A2”）。值*范围（“C2”）。值+ Now（）
A2是单位数量，C2是过程时间0,1,5
非常感谢您的帮助/build议
我不确定是什么问题。 math是（单位*每单位时间）+开始时间。 括号仅用于视觉上的好处; math优先级将确保乘法在加法之前发生。
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，我使用.Value2取代了.Value因为它是一个没有附加date/时间/货币信息的原始数字，所以我已经取得了更好的成功。
这花了一点时间，但结果相当不错。 按照这些说明进行testing。 在要执行操作的工作簿中创build一个标准代码模块。 名称默认为“Module1”。 我build议你把它改成“Main”或者一些更好的描述性的名字。 将以下枚举粘贴到模块的顶部，包括选项语句。
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
此枚举用于标识工作表中的行和列。 请注意，列是编号（1 = A，2 = B，3 = C等）没有值的枚举假设前一个+1的值。 因此，NwsEnd = 4 = D列。您可以根据枚举设置工作表，或调整枚举值以匹配工作表，但必须为每个“数量”，“生产时间”，“生产开始时间”和“生产完成”时间。 NwsFirstDataRow用来防止macros改变你不想改变的数据 – 至less在标题行中，这里假设是第1行。现在通过下面的枚举。
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
这个枚举为你的轮class时间保存一个代码。 将来，如果您的工作时间发生变化，只需更改这些数字即可修改代码的输出。 下一个小组正在完成大部分工作。
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
其基本的计算方法是首先计算从生产开始到当天结束时可以生产多less个单位。 然后计算全天的产量，并从最后一天剩余的单位数量计算完成。 如果缺less3个所需组件（数量，时间，开始时间）中的任何一个，则不会进行此类计算。 以下function帮助计算。 将它们粘贴在同一个“主”代码模块的底部。
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
计算从开始时间到第一个生产date结束时可以产生的数量。 下一个函数计算整天的生产。
Private Function DailyProduction(UnitTime As Double) As Integer ' 19 Mar 2017 DailyProduction = Int((NshToDays(NshEnd) - NshToDays(NshStart) + 0.000001) / UnitTime) End Function
在处理时间计算所需的Doubletypes数字时，VB难以计算零点。 结果中添加的0.000001确保在需要零时，计算结果不会低于零。 下一个函数将从Enum Nsh编码的转换时间转换为该程序可以使用的几个小时。
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
下一个函数纠正StartTime列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
这个function的作用是确保没有人像上午4点那样进入时间。 如果有人这样做，那么入场时间将会更改为05:30，因为这是轮class开始的时间。 此代码表中的最后一个过程格式化单元格。
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
只要input生产数量，就会调用这个子部分。 您可以在这里调整单元格格式。 这尤其适用于我可能没有按照自己的喜好做的date格式。
现在，仍然在VBE窗口中，find列表上面第一列的工作表的代码表。 它可能在工程窗口中以Sheet1(Sheet1)或类似的方式列出。 确定正确的工作表并在其中粘贴以下程序非常重要。
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
通过阅读它可以吐出的各种错误信息，你可以清楚地知道这个过程的作用。 您可以修改这些文本。 请注意，您可以input开始时间作为时间或date/时间。 如果只input时间，macros将自动添加当前date。 在没有错误的情况下，这个macros将调用子SetCompletion ，如果所有的计算标准都存在，它将把完成date写入工作表。 请注意，更改Enum Nsh后，您的数据不会受到保护。 为避免覆盖以先前正确的移位时间计算的现有完成date，请将枚举NwsFirstDataRow设置为以这种方式排除希望保护的行。
所有的组件都经过了testing，但是整个项目相当复杂，你可以在现实生活中观察结果。 您可能已经注意到，我已经将代码结构化，使得错误很容易归因于特定的function，而这些function可能不得不改进，而不会造成任何问题。
问题在于date格式，更具体地说是开始时间列中的inputdate格式。 macros只会计算开始时间是否给定。 所以，当开始时间被给出但是没有被识别为没有计算发生。
我编程的日/月/年，你正在使用美国系统。 请用这个replace现有的同名程序。
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
对事件程序也做了修改，现在将识别以您的格式input的date。 请记住，您应该能够在7:30开始input开始时间，并在3月25日07:30之前显示单元格。 尝试这个。 也尝试进入“3月20日7:30”，“3/20/17 7:30”，“3/20 7:30”，然后“3/20/17 14:00”或者“3/20 / 17 2:00 PM“。 如果它不起作用，那就意味着背后更大的错误。
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
最后但并非最不重要的是，我发现计算完成时间的错误影响了不是在同一天结束的生产时间。 我纠正了它。 请交换function。
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
其实，这个程序应该进一步修改，以确认周末，但我希望你的生产不会停止在星期天:-)
如果您仍然遇到date问题，我将非常感谢您的支持。 我可以改变我的电脑上的默认设置，以便更好的testing，但到目前为止，我已经避免了这样做。 🙂
事件过程中的文本应根据您要对代码进行的更改进行更改。 请replace如下：
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"
意思是，在上面的起始处查找带有撇号的代码行，并用没有撇号的留置符replace它们。
我build议你在刚刚开始的新主题中发布一个链接到这个主题。