Question

我正在尝试使用三班制生产环境中的操作日志转换文件，以便能够按班次（const 7-15,15-23,23-7）对它们进行分组，即如果两者都开始日期/时间和记录的结束日期/时间不在同一班次内，然后复制下面的行，并将原始结束日期/时间和重复的结束日期/时间更改为相应的班次。

Event   Start date/time    End date/time      Shift Start    Shift End
A       18/05/2017 4:30    18/05/2017 11:45   Mid (23-7)     Day (7-15)

转换为：

Event   Start date/time    End date/time      Shift Start    Shift End
A       18/05/2017 4:30    18/05/2017 7:00    Mid (23-7)     Mid (23-7)
A       18/05/2017 7:00    18/05/2017 11:45   Day (7-15)     Day (7-15)

不幸的是我对VBA不够好，所以在开始时我试图仅使用excel公式解决这个问题，并添加了一个列，显示事件持续了多少次移动（等于行数的X行数）必须加倍），这可能有助于迭代。

Event    Start date/time    End date/time     Shift Start    Shift End    X
A        18/05/2017 4:30    18/05/2017 23:30  Mid (23-7)     Mid (23-7)   3

背后的逻辑：

Event    Start date/time    End date/time     Shift Start    Shift End    X
A        18/05/2017 4:30    18/05/2017 7:00   Mid (23-7)     Mid (23-7)   ""
A        18/05/2017 7:00    18/05/2017 23:30  Day (7-15)     Mid (23-7)   2

预期结果：

Event    Start date/time    End date/time     Shift Start    Shift End    X
A        18/05/2017 4:30    18/05/2017 7:00   Mid (23-7)     Mid (23-7)   ""
A        18/05/2017 7:00    18/05/2017 15:00  Day (7-15)     Day (7-15)   ""
A        18/05/2017 15:00   18/05/2017 23:00  Aft (15-23)    Aft (15-23)  ""
A        18/05/2017 23:00   18/05/2017 23:30  Mid (23-7)     Mid (23-7)   ""

我一直试图解决这个问题需要几个小时才能获得互联网，最终我只能复制行数X次以下，让F栏空白，但我觉得这是一个死胡同。任何帮助将不胜感激！

谢谢！

修改

Sub duplicate()
Dim lngRow As Long, copyRows As Integer

Application.ScreenUpdating = False
lngRow = 2 '1. header
Do Until IsEmpty(Range("A" & lngRow))
    If Range("F" & lngRow).Value >= 1 Then 'check if the row should be duplicate
        copyRows = Range("F" & lngRow).Value
        Range("F" & lngRow + 1 & ":F" & lngRow + copyRows).EntireRow.Insert
        Range("A" & lngRow & ":F" & (lngRow + copyRows)).FillDown 'was just testing the code. here I think I should work on cells and defined const. do I need an array to solve that problem?
        Range("F" & lngRow & ":F" & (lngRow + copyRows)).Value = ""
        lngRow = lngRow + copyRows
    End If
    lngRow = lngRow + 1
Loop
End Sub

编辑2 这是我写的第一个代码，抱歉有任何错误。我知道这不是最干净的代码，但我会尽我所能。

Sub duplicate2()
Dim lngRow As Long, copyRows As Integer

Application.ScreenUpdating = False
lngRow = 2 '1. header
Do Until IsEmpty(Range("A" & lngRow))
    If Range("F" & lngRow).Value >= 1 Then 'check if the row should be duplicated
        copyRows = Range("F" & lngRow).Value 'ok
        Range("F" & lngRow + 1 & ":F" & lngRow + 1).EntireRow.Insert 'insert a row below
        Range("F" & lngRow + 1 & ":F" & lngRow + 1).Value = copyRows - 1 'decrease X by 1
        Range("F" & lngRow & ":F" & lngRow).Value = "" 'clean original X
        Range("A" & lngRow + 1 & ":E" & lngRow + 1).FillDown 'duplicate row

        'here I should work on cells and defined const. do I need an array to solve that problem?

    End If
    lngRow = lngRow + 1
Loop
End Sub

Sub duplicate()
Dim lngRow As Long, copyRows As Integer

Application.ScreenUpdating = False
lngRow = 2 '1. header
Do Until IsEmpty(Range("A" & lngRow))
    If Range("F" & lngRow).Value >= 1 Then 'check if the row should be duplicate
        copyRows = Range("F" & lngRow).Value
        Range("F" & lngRow + 1 & ":F" & lngRow + copyRows).EntireRow.Insert
        Range("A" & lngRow & ":F" & (lngRow + copyRows)).FillDown 'was just testing the code. here I think I should work on cells and defined const. do I need an array to solve that problem?
        Range("F" & lngRow & ":F" & (lngRow + copyRows)).Value = ""
        lngRow = lngRow + copyRows
    End If
    lngRow = lngRow + 1
Loop
End Sub

Answer 1

您可以尝试使用此宏按shift拆分行。仅使用A-C列而不使用其他辅助列。它可以处理可以跨越多天的持续时间，因为它处理日期并使用专用函数精确计算移位（请参阅下面的效用函数shifEnd）。

Sub SplitShifts()
  Application.ScreenUpdating = False: Application.EnableEvents = False
  On Error GoTo Cleanup

  Dim r As Range: Set r = Sheet1.Range("A2:F2")
  Do Until Len(Trim(r(1))) = 0 ' loop until row is empty
    If shiftEnd(r(2)) >= r(3) Then
      Set r = r.Offset(1) ' no split needed, next row
    Else ' insert new row and split shifts
      r.Copy: r.Insert Shift:=xlDown
      r(2) = shiftEnd(r(2))
      r(0, 3) = r(2)
    End If
  Loop

Cleanup:
  Application.ScreenUpdating = True: Application.EnableEvents = True: Application.CutCopyMode = False
End Sub

Function shiftEnd(ByVal d As Date) As Date
  Select Case Hour(d)
    Case 0 To 6: shiftEnd = Int(d) + TimeSerial(7, 0, 0)
    Case 7 To 14: shiftEnd = Int(d) + TimeSerial(15, 0, 0)
    Case 15 To 22: shiftEnd = Int(d) + TimeSerial(23, 0, 0)
    Case 23: shiftEnd = Int(d) + 1 + TimeSerial(7, 0, 0) ' Next day 7:00
  End Select
End Function

<强>测试

Event   Start date      End date
A       5/18/17 4:30    5/18/17 21:18
B       5/20/17 18:54   5/22/17 2:06
C       5/22/17 11:42   5/23/17 6:54
D       5/25/17 16:30   5/26/17 6:54
E       5/26/17 4:30    5/26/17 18:54
F       5/27/17 4:30    5/28/17 14:06
G       5/30/17 16:30   5/31/17 23:42

Excel VBA：根据日期/时间条件复制和划分行

1 个答案: