Разделение временного интервала на полчаса

Question

У меня есть такая таблица

Исходная таблица

Дата начала и Дата окончания, содержащие формулу, которую вы можете см. в строке формул. Я хочу разделить диапазон на полчаса, чтобы таблица выглядела следующим образом

Таблица результатов

Любой код макроса Идея, что я могу бежать за этим условием? Я также предпочитаю, чтобы макрос мог запускаться автоматически и занимать более одного часа.

В любом случае, я попробовал этот код от другого пользователя, и он работает, когда формат времени не в формуле, но когда я изменяю его на формулу , он показывает несоответствие типа ошибки

Код 1

Sub sample()
Dim bufF As String, bufT As String, NO As String, name As String, day As 
String, Min As String, Min2 As String
Dim i As Long, j As Single, LastR1 As Long, LastR2 As Long
Dim ws1 As Worksheet, ws2 As Worksheet
Dim x() As String, y() As String, cnt As Long
Set ws1 = Sheets("data") '<--change the sheet name
Set ws2 = Sheets("result") '<--change the sheet name

With ws1
LastR1 = .Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To LastR1
    NO = .Cells(i, 1).Value
    name = .Cells(i, 2).Value
    bufF = InStr(Format(.Cells(i, 4).Value, "ddmmyyyy hh:mm"), " ")
    bufF = Mid(Format(.Cells(i, 4).Value, "ddmmyyyy hh:mm"), bufF + 1, 2)
    bufT = InStr(Format(.Cells(i, 5).Value, "ddmmyyyy hh:mm"), " ")
    bufT = Mid(Format(.Cells(i, 5).Value, "ddmmyyyy hh:mm"), bufT + 1, 2)
    Min = InStr(Format(.Cells(i, 4).Value, "ddmmyyyy hh:mm"), ":")
    Min = Mid(Format(.Cells(i, 4).Value, "ddmmyyyy hh:mm"), Min + 1, 2)
    Min2 = InStr(Format(.Cells(i, 5).Value, "ddmmyyyy hh:mm"), ":")
    Min2 = Mid(Format(.Cells(i, 5).Value, "ddmmyyyy hh:mm"), Min2 + 1, 2)
    day = Format(.Cells(i, 4).Value, "dd-mm-yyyy ")
        If bufT = "00" Then bufT = 24
        With ws2
            LastR2 = .Cells(Rows.Count, 1).End(xlUp).Row
            ReDim x(bufT * 2 - bufF * 2)
            ReDim y(bufT * 2 - bufF * 2)
            If Min = "30" Then bufF = bufF + 0.5
            If Min2 = "30" Then bufT = bufT + 0.5
            For j = bufF * 1 To bufT * 1 - 0.5 Step 0.5
            If j = Int(j) Then
                x(cnt) = day & j & ":00"
                y(cnt) = NO & "-" & j
                cnt = cnt + 1

            Else
                x(cnt) = day & Int(j) & ":30"
                y(cnt) = NO & "-" & j
                cnt = cnt + 1

            End If
            Next j
            .Range(.Cells(LastR2 + 1, 1), .Cells(LastR2 + cnt, 1)).Value = 
            WorksheetFunction.Transpose(y)
            .Range(.Cells(LastR2 + 1, 3), .Cells(LastR2 + cnt, 3)).Value = 
            WorksheetFunction.Transpose(x)
            .Range(.Cells(LastR2 + 1, 2), .Cells(LastR2 + cnt, 2)).Value = 
            name
        End With
        cnt = 0
Next
End With
End Sub

Код 2

Sub RevisedSample()
Dim myName As String 'Name could be confused with the Excel '.Name' 
property.
Dim StartTime As Date, EndTime As Date
Dim Activity As String, Detail As String
Dim LastRowSource As Long, LastRowDestination As Long, LoopCountSource As 
Long, LoopCountDestination As Long
Dim ThirtyMinInterval As Boolean: ThirtyMinInterval = False 'Explicitly 
assigning False to variable
Dim StringStartTime As String, StringEndTime As String
Dim Time As String
Dim TimeArray As Variant
Dim ArrayCounter As Long

Set SourceSheet = Sheets("Sheet1") '<--change the sheet name
Set DestinationSheet = Sheets("Sheet2") '<--change the sheet name

With SourceSheet
LastRowSource = .Cells(Rows.Count, 1).End(xlUp).Row
For LoopCountSource = 2 To LastRowSource
    myName = .Cells(LoopCountSource, 1).Value
    Activity = .Cells(LoopCountSource, 2).Value
    StartTime = .Cells(LoopCountSource, 4).Value
    EndTime = .Cells(LoopCountSource, 5).Value

    If DateDiff("n", StartTime, EndTime) > 30 Then
        ThirtyMinInterval = True

        StringStartTime = CStr(StartTime)
        StringEndTime = CStr(EndTime)

        Time = InStr(Format(StringStartTime, "ddmmyyyy hh:mm"), " ")
        Time = Mid(Format(StringStartTime, "ddmmyyyy hh:mm"), Time + 1, 2)
        Time = Time & ":30"
        StringEndTime = Format(Mid(StringStartTime, 1, 8), "dd/mm/yyyy") & 
        " " & Time

        ReDim TimeArray(1 To 2)
        TimeArray(1) = StartTime
        TimeArray(2) = CDate(StringEndTime)
    End If

    Detail = .Cells(LoopCountSource, 3).Value

    With DestinationSheet
        LastRowDestination = .Cells(Rows.Count, 1).End(xlUp).Row + 1
        If ThirtyMinInterval = True Then
            ArrayCounter = 1
            For LoopCounterDestination = LastRowDestination To 
            LastRowDestination + (UBound(TimeArray) - 1)
                .Range("A" & LoopCounterDestination).Value = myName
                .Range("B" & LoopCounterDestination).Value = 
                TimeArray(ArrayCounter)
                .Range("C" & LoopCounterDestination).Value = Activity
                .Range("D" & LoopCounterDestination).Value = Detail

                ArrayCounter = ArrayCounter + 1
            Next LoopCounterDestination
        Else
                .Range("A" & LastRowDestination).Value = myName
                .Range("B" & LastRowDestination).Value = StartTime
                .Range("C" & LastRowDestination).Value = Activity
                .Range("D" & LastRowDestination).Value = Detail
        End If
    End With
    ThirtyMinInterval = False
Next LoopCountSource
End With

End Sub

для второго кода, требуется модификация, чтобы он занимал более одного часа интервал времени

Answer 1

Try,

Sub test()
    Dim Ws As Worksheet, toWs As Worksheet
    Dim vDB, vR()
    Dim st As Double, et As Double
    Dim dStep As Double
    Dim i As Long, r As Long
    Dim j As Double
    Dim k As Integer

    dStep = 1 / 48 '<~~ Half Hour: TimeSerial(0, 30, 0)

    Set Ws = Sheets(1)   '<~~ your data Sheet
    Set toWs = Sheets(2) '<~~ your result Sheet


    With Ws
        vDB = .Range("g2", .Range("O" & Rows.Count).End(xlUp))
    End With
    r = UBound(vDB, 1)

    For i = 1 To r
        st = vDB(i, 8)
        et = vDB(i, 9) - TimeSerial(0, 0, 1)
        For j = st To et Step dStep
            n = n + 1
            ReDim Preserve vR(1 To 5, 1 To n)
            For k = 1 To 4
                vR(k, n) = vDB(i, k)
            Next k
            vR(5, n) = DateSerial(vDB(i, 7), vDB(i, 6), vDB(i, 5)) + j
        Next j
    Next i

    With toWs
        .UsedRange.Clear
        .Range("a1").Resize(1, 5) = Array("Activity No", "User", "Activity", "Description", "Time")
        .Range("a2").Resize(n, 5) = WorksheetFunction.Transpose(vR)
        .Columns("E").NumberFormatLocal = "dd/mm/yyyy hh:mm"
    End With

End Sub

Таблица данных

Таблица результатов