VBA代码在某些情况下无法正常工作。

huangapple
go评论125阅读模式
英文:

VBA code not working correctly in some scenario's

问题

好的，以下是翻译好的内容：

VBA代码在某些情况下无法正常工作。你好，

希望有人能帮忙解决以下问题。

这是标准：

周一至周五：06:00至7:30（每小时2分）14:00至17:00（每小时1分）17:00至19:00（每小时2分）19:00至01:00（每小时3分）

周六06:00至17:00（每小时2分）17:00至01:00（每小时3分）

周日06:00至17:00（每小时2分）17:00至01:00（每小时4分）

这是代码：

  1. Sub CalculateOvertimePoints()
  2.     Dim i As Long
  3.     Dim lastRow As Long
  4.     Dim startTime As Date, endTime As Date
  5.     Dim timeString As String
  6.     Dim duration As Double
  7.     
  8.     ' 获取E列的最后一行
  9.     lastRow = Cells(Rows.Count, "E").End(xlUp).Row
  10.     
  11.     ' 循环遍历从30行到最后一行的每一行
  12.     For i = 30 To lastRow
  13.         timeString = Cells(i, "F").Value
  14.         If InStr(1, timeString, "-") > 0 Then
  15.             startTime = TimeValue(Split(timeString, "-")(0))
  16.             endTime = TimeValue(Split(timeString, "-")(1))
  17.             
  18.             If endTime < startTime Then
  19.                 endTime = DateAdd("d", 1, endTime)
  20.             End If
  22.             duration = endTime - startTime
  23.             If duration > 0 Then
  24.                 Dim points As Double
  25.                 points = 0
  26.                 
  27.                 Dim currentTime As Date
  28.                 currentTime = startTime
  29.                 
  30.                 While currentTime < endTime
  31.                     Dim nextTime As Date
  32.                     nextTime = DateAdd("n", 30, currentTime)
  33.                     
  34.                     Dim hourPoints As Double
  35.                     hourPoints = 0
  36.                     
  37.                     Select Case Cells(i, "E").Value
  38.                         Case "Monday-Friday"
  39.                             If (currentTime >= TimeValue("06:00") And currentTime < TimeValue("07:30")) Then
  40.                                 hourPoints = 1
  41.                             ElseIf (currentTime >= TimeValue("14:00") And currentTime < TimeValue("17:00")) Then
  42.                                 hourPoints = 0.5
  44.                             ElseIf (currentTime >= TimeValue("17:00") And currentTime < TimeValue("19:00")) Then
  45.                                 hourPoints = 1
  46.                             ElseIf (currentTime >= TimeValue("19:00") Or currentTime < TimeValue("01:00")) Then
  47.                                 hourPoints = 1.5
  48.                             End If
  49.                             
  50.                         Case "Saturday"
  51.                             If (currentTime >= TimeValue("06:00") And currentTime < TimeValue("17:00")) Then
  52.                                 hourPoints = 1
  53.                                 
  54.                             ElseIf (currentTime >= TimeValue("17:00") And currentTime < TimeValue("19:00")) Then
  55.                                 hourPoints = 1
  56.                             ElseIf (currentTime >= TimeValue("19:00") Or currentTime < TimeValue("02:00")) Then
  57.                                 hourPoints = 1.5
  58.                             End If
  59.                             
  60.                         Case "Sunday"
  61.                             If (currentTime >= TimeValue("06:00") And currentTime < TimeValue("17:00")) Then
  62.                                 hourPoints = 2
  63.                             ElseIf (currentTime >= TimeValue("17:00") And currentTime < TimeValue("18:00")) Then
  64.                                 hourPoints = 1
  65.                             ElseIf (currentTime >= TimeValue("18:00") And currentTime < TimeValue("19:00")) Then
  66.                                 hourPoints = 2
  67.                             End If
  68.                     End Select
  69.                     
  70.                     points = points + hourPoints
  71.                     
  72.                     currentTime = nextTime
  73.                 Wend
  74.                 
  75.                 ' 根据小数小时调整分数
  76.                 Dim fractionalHours As Double
  77.                 fractionalHours = (endTime - startTime) * 24 Mod 1
  78.                 points = points + fractionalHours * (hourPoints / 60)
  79.                 totalPoints = totalPoints - prevHourPoints ' 减去上一个hourPoints的值
  80.     totalPoints = totalPoints + fractionalHours * (prevHourPoints / 1) ' 计算小数点
  81.                 Cells(i, "L").Value = points
  82.             Else
  83.                 Cells(i, "L").Value = 0
  84.             End If
  85.         Else
  86.             Cells(i, "L").Value = 0
  87.         End If
  88.     Next i
  89. End Sub

我附上了3个场景的图片-第一个答案应该是4.5，第二个答案应该是12，第三个答案应该是24。

希望有人能帮忙，谢谢。

这段代码在某些场景下存在问题，我不太理解，如果你将时间稍微推后一点，它就能正确运行。

英文:

VBA代码在某些情况下无法正常工作。Good day,

was hoping someone could help with the following.

this is the criteria:

Monday to Friday:06:00 to 7:30 (2 points per hour) 14:00 to 17:00 (1 point per hour) 17:00 to 19:00 (2 points per hour) 19:00-01:00 (3 points per hour)

Saturday 06:00 to 17:00 (2 points per hour) 17:00 to 01:00 (3 points per hour)

Sunday 06:00 to 17:00 (2 points per hour) 17:00 to 01:00 (4 points per hour)

This is the code:

  1. Sub CalculateOvertimePoints()
  2.     Dim i As Long
  3.     Dim lastRow As Long
  4.     Dim startTime As Date, endTime As Date
  5.     Dim timeString As String
  6.     Dim duration As Double
  7.     
  8.     ' Get the last row in column E
  9.     lastRow = Cells(Rows.Count, "E").End(xlUp).Row
  10.     
  11.     ' Loop through each row from 30 to the last row
  12.     For i = 30 To lastRow
  13.         timeString = Cells(i, "F").Value
  14.         If InStr(1, timeString, "-") > 0 Then
  15.             startTime = TimeValue(Split(timeString, "-")(0))
  16.             endTime = TimeValue(Split(timeString, "-")(1))
  17.             
  18.             If endTime < startTime Then
  19.                 endTime = DateAdd("d", 1, endTime)
  20.             End If
  22.             duration = endTime - startTime
  23.             If duration > 0 Then
  24.                 Dim points As Double
  25.                 points = 0
  26.                 
  27.                 Dim currentTime As Date
  28.                 currentTime = startTime
  29.                 
  30.                 While currentTime < endTime
  31.                     Dim nextTime As Date
  32.                     nextTime = DateAdd("n", 30, currentTime)
  33.                     
  34.                     Dim hourPoints As Double
  35.                     hourPoints = 0
  36.                     
  37.                     Select Case Cells(i, "E").Value
  38.                         Case "Monday-Friday"
  39.                             If (currentTime >= TimeValue("06:00") And currentTime < TimeValue("07:30")) Then
  40.                                 hourPoints = 1
  41.                             ElseIf (currentTime >= TimeValue("14:00") And currentTime < TimeValue("17:00")) Then
  42.                                 hourPoints = 0.5
  44.                             ElseIf (currentTime >= TimeValue("17:00") And currentTime < TimeValue("19:00")) Then
  45.                                 hourPoints = 1
  46.                             ElseIf (currentTime >= TimeValue("19:00") Or currentTime < TimeValue("01:00")) Then
  47.                                 hourPoints = 1.5
  48.                             End If
  49.                             
  50.                         Case "Saturday"
  51.                             If (currentTime >= TimeValue("06:00") And currentTime < TimeValue("17:00")) Then
  52.                                 hourPoints = 1
  53.                                 
  54.                             ElseIf (currentTime >= TimeValue("17:00") And currentTime < TimeValue("19:00")) Then
  55.                                 hourPoints = 1
  56.                             ElseIf (currentTime >= TimeValue("19:00") Or currentTime < TimeValue("02:00")) Then
  57.                                 hourPoints = 1.5
  58.                             End If
  59.                             
  60.                         Case "Sunday"
  61.                             If (currentTime >= TimeValue("06:00") And currentTime < TimeValue("17:00")) Then
  62.                                 hourPoints = 2
  63.                             ElseIf (currentTime >= TimeValue("17:00") And currentTime < TimeValue("18:00")) Then
  64.                                 hourPoints = 1
  65.                             ElseIf (currentTime >= TimeValue("18:00") And currentTime < TimeValue("19:00")) Then
  66.                                 hourPoints = 2
  67.                             End If
  68.                     End Select
  69.                     
  70.                     points = points + hourPoints
  71.                     
  72.                     currentTime = nextTime
  73.                 Wend
  74.                 
  75.                 ' Adjust points based on fractional hours
  76.                 Dim fractionalHours As Double
  77.                 fractionalHours = (endTime - startTime) * 24 Mod 1
  78.                 points = points + fractionalHours * (hourPoints / 60)
  79.                 totalPoints = totalPoints - prevHourPoints ' Subtract the last hourPoints value
  80.     totalPoints = totalPoints + fractionalHours * (prevHourPoints / 1) ' Calculate fractional points
  81.                 
  82.                 Cells(i, "L").Value = points
  83.             Else
  84.                 Cells(i, "L").Value = 0
  85.             End If
  86.         Else
  87.             Cells(i, "L").Value = 0
  88.         End If
  89.     Next i
  90. End Sub

I attached a picture of 3 scenario's - 1Ste answer should be 4.5 second one should be 12 and 3de one should be 24.

Hope someone can help, thank you.

The code has issu's with only some scenario's and I dont understand it, if you change the times to maybe a bit later then it works out correctly.

答案1

得分: 1

对你的错误进行评论：
1）5.5是正确的。1pt/hr（2hrs + .5hr）* 1pt/hr = 2.5pts，2pts/hr组=（1hr + .5hr）* 2pt/hr = 3pt。总计为2.5 + 3 = 5.5。
2）我没有花足够的时间来弄清楚为什么，但是当currentTime和endTime都是下午1:00时，它会进入你的While循环，即使使用的是“<”而不是“<=”。
3）1:30超出了你的规则范围，星期六从[17:00,01:00]开始..而且我认为你的任何跨越到第二天的范围都会遇到问题。

我重新编写了代码，不是计算半小时的“bean”来计算你的点数，而是找到相交的日期时间范围，并计算小时差并应用你的乘数。

  1. Sub CalcOTPts()
  2.     Dim startTime As Date, endTime As Date
  3.     Dim timeString As String
  4.     Dim oPts As Double
  5.     
  6.     Dim i As Integer
  7.     For i = 30 To Cells(Rows.Count, "E").End(xlUp).Row
  8.         timeString = Cells(i, "F").Value
  9.         If InStr(1, timeString, "-") > 0 Then
  10.             startTime = TimeValue(Split(timeString, "-")(0))
  11.             endTime = TimeValue(Split(timeString, "-")(1))
  12.             
  13.             If endTime < startTime Then
  14.                 endTime = DateAdd("d", 1, endTime)
  15.             End If
  17.             oPts = 0
  18.             Select Case Cells(i, "E").Value
  19.                 Case "Monday-Friday"
  20.                     oPts = oPts + CalcPts(startTime, endTime, "6:00", "7:30", 2)
  21.                     oPts = oPts + CalcPts(startTime, endTime, "14:00", "17:00", 1)
  22.                     oPts = oPts + CalcPts(startTime, endTime, "17:00", "19:30", 2)
  23.                     oPts = oPts + CalcPts(startTime, endTime, "19:00", "01:00", 3)
  24.                 Case "Saturday"
  25.                     oPts = oPts + CalcPts(startTime, endTime, "06:00", "17:00", 2)
  26.                     ' Extended rule to 3:00 to test
  27.                     oPts = oPts + CalcPts(startTime, endTime, "17:00", "03:00", 3)
  28.                 Case "Sunday"
  29.                     oPts = oPts + CalcPts(startTime, endTime, "06:00", "17:00", 3)
  30.                     oPts = oPts + CalcPts(startTime, endTime, "17:00", "01:00", 4)
  31.             End Select
  32.             
  33.             Cells(i, "M").Value = oPts
  34.             
  35.         End If
  36.     Next
  37. End Sub
  40. Private Function CalcPts(ByVal startTime As Date, ByVal endTime As Date, startTimeRule As Date, endTimeRule As Date, multiplier As Double) As Double
  41.     ' Finds the intersecting time between the two ranges and applies the hourly modifier
  42.     
  43.     Dim oStartIntersection As Date
  44.     Dim oEndIntersection As Date
  45.     
  46.     ' Assume it's the next day if the endtime is less than starttime
  47.     If endTimeRule < startTimeRule Then
  48.         endTimeRule = DateAdd("d", 1, endTimeRule)
  49.     End If
  50.     
  51.     CalcPts = 0     ' Default to not add any points
  52.     If (startTime < endTimeRule) And (endTime > startTimeRule) Then
  53.         'There is an intersection beween these two date ranges
  54.         
  55.         ' Find the start time for the intersection
  56.         If startTime > startTimeRule Then
  57.             oStartIntersection = startTime
  58.         Else
  59.             oStartIntersection = startTimeRule
  60.         End If
  61.         
  62.         ' Find the end time for the intersection
  63.         If endTime < endTimeRule Then
  64.             oEndIntersection = endTime
  65.         Else
  66.             oEndIntersection = endTimeRule
  67.         End If
  68.         
  69.         ' Calculate the points
  70.         CalcPts = DateDiff("n", oStartIntersection, oEndIntersection) / 60 * multiplier
  71.     End If
  72.     
  73. End Function
英文:

Comments on your error's

  1. 5.5 is correct. 1pt/hr (2hrs + .5hr)*1pt/hr = 2.5pts, 2pts/hr group = (1hr + .5hr)*2pt/hr = 3pt. Which totals 2.5+3 = 5.5
  2. I haven't spent enough time to be able to figure out why but it's entering your While loop when currentTime and endTime are both 1:00 PM, even with a "<" not "<="
  3. 1:30 is outside the range of your rules Saturday goes from [17:00,01:00].. also I think you will run into problems with any of your ranges that are going over to the next day.

Instead of counting half-hour "bean's" to tally up your points, I re-wrote it to find intersecting date time ranges and taking the difference in hours and applying your multiplier.

  1.     Sub CalcOTPts()
  2.         Dim startTime As Date, endTime As Date
  3.         Dim timeString As String
  4.         Dim oPts As Double
  5.         
  6.         Dim i As Integer
  7.         For i = 30 To Cells(Rows.Count, &quot;E&quot;).End(xlUp).Row
  8.             timeString = Cells(i, &quot;F&quot;).Value
  9.             If InStr(1, timeString, &quot;-&quot;) &gt; 0 Then
  10.                 startTime = TimeValue(Split(timeString, &quot;-&quot;)(0))
  11.                 endTime = TimeValue(Split(timeString, &quot;-&quot;)(1))
  12.                 
  13.                 If endTime &lt; startTime Then
  14.                     endTime = DateAdd(&quot;d&quot;, 1, endTime)
  15.                 End If
  16.     
  17.                 oPts = 0
  18.                 Select Case Cells(i, &quot;E&quot;).Value
  19.                     Case &quot;Monday-Friday&quot;
  20.                         oPts = oPts + CalcPts(startTime, endTime, &quot;6:00&quot;, &quot;7:30&quot;, 2)
  21.                         oPts = oPts + CalcPts(startTime, endTime, &quot;14:00&quot;, &quot;17:00&quot;, 1)
  22.                         oPts = oPts + CalcPts(startTime, endTime, &quot;17:00&quot;, &quot;19:30&quot;, 2)
  23.                         oPts = oPts + CalcPts(startTime, endTime, &quot;19:00&quot;, &quot;01:00&quot;, 3)
  24.                     Case &quot;Saturday&quot;
  25.                         oPts = oPts + CalcPts(startTime, endTime, &quot;06:00&quot;, &quot;17:00&quot;, 2)
  26.                         &#39; Extended rule to 3:00 to test
  27.                         oPts = oPts + CalcPts(startTime, endTime, &quot;17:00&quot;, &quot;03:00&quot;, 3)
  28.                     Case &quot;Sunday&quot;
  29.                         oPts = oPts + CalcPts(startTime, endTime, &quot;06:00&quot;, &quot;17:00&quot;, 3)
  30.                         oPts = oPts + CalcPts(startTime, endTime, &quot;17:00&quot;, &quot;01:00&quot;, 4)
  31.                 End Select
  32.                 
  33.                 Cells(i, &quot;M&quot;).Value = oPts
  34.                 
  35.             End If
  36.         Next
  37.     End Sub
  38.     
  39.     
  40.     Private Function CalcPts(ByVal startTime As Date, ByVal endTime As Date, startTimeRule As Date, endTimeRule As Date, multiplier As Double) As Double
  41.         &#39; Finds the intersecting time between the two ranges and applies the hourly modifier
  42.         
  43.         Dim oStartIntersection As Date
  44.         Dim oEndIntersection As Date
  45.         
  46.         &#39; Assume it&#39;s the next day if the endtime is less than starttime
  47.         If endTimeRule &lt; startTimeRule Then
  48.             endTimeRule = DateAdd(&quot;d&quot;, 1, endTimeRule)
  49.         End If
  50.         
  51.         CalcPts = 0     &#39; Default to not add any points
  52.         If (startTime &lt; endTimeRule) And (endTime &gt; startTimeRule) Then
  53.             &#39;There is an intersection beween these two date ranges
  54.             
  55.             &#39; Find the start time for the intersection
  56.             If startTime &gt; startTimeRule Then
  57.                 oStartIntersection = startTime
  58.             Else
  59.                 oStartIntersection = startTimeRule
  60.             End If
  61.             
  62.             &#39; Find the end time for the intersection
  63.             If endTime &lt; endTimeRule Then
  64.                 oEndIntersection = endTime
  65.             Else
  66.                 oEndIntersection = endTimeRule
  67.             End If
  68.             
  69.             &#39; Calculate the points
  70.             CalcPts = DateDiff(&quot;n&quot;, oStartIntersection, oEndIntersection) / 60 * multiplier
  71.         End If
  72.         
  73.     End Function

huangapple
  • 本文由 发表于 2023年7月27日 18:10:00
  • 转载请务必保留本文链接：https://go.coder-hub.com/76778677.html
  • calculation
  • excel
  • math
  • time
  • vba
匿名

发表评论

匿名网友

:?: :razz: :sad: :evil: :!: :smile: :oops: :grin: :eek: :shock: :???: :cool: :lol: :mad: :twisted: :roll: :wink: :idea: :arrow: :neutral: :cry: :mrgreen:

确定