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

Question

У меня есть набор данных, который выглядит следующим образом

И я хочу разделить его, чтобы данные стали такими:

Любая идея кода VBA? Спасибо!

Я пробовал этот код от пользователя на другом форуме, но он показывает только 1-часовой интервал времени. Не могли бы вы помочь мне сделать так, чтобы интервал времени составлял 30 минут?

Sub sample()
Dim bufF As String, bufT As String, NO As String, name As String, 
day As String
Dim i As Long, j As Long, 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, 3).Value, "ddmmyyyy hh:mm"), " ")
        bufF = Mid(Format(.Cells(i, 3).Value, "ddmmyyyy hh:mm"), bufF 
        + 1, 2)
        bufT = InStr(Format(.Cells(i, 4).Value, "ddmmyyyy hh:mm"), " ")
        bufT = Mid(Format(.Cells(i, 4).Value, "ddmmyyyy hh:mm"), bufT 
        + 1, 2)
        day = Format(.Cells(i, 3).Value, "dd-mm-yyyy ")
            If bufT = "00" Then bufT = 24
            With ws2
                LastR2 = .Cells(Rows.Count, 1).End(xlUp).Row
                ReDim x(bufT * 1 - bufF * 1)
                ReDim y(bufT * 1 - bufF * 1)

                For j = bufF * 1 To bufT * 1 - 1
                    x(cnt) = day & j & ":00"
                    y(cnt) = NO & "-" & j
                    cnt = cnt + 1
                Next
                .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

Answer 1

Переписываем ваш существующий код, это проверено и работает. Читаемость намного проще, а с описательными именами переменных легче увидеть, что делает каждая строка.

Примечание: Это позволит найти только получасовые интервалы между 1 часом. Например, если время начала - 09:00, а время окончания - 11:00, будет возвращено только время для 09:00 и 09: 30.

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

Скриншоты исходного листа ( Sheet1) и лист назначения (Sheet2):

Лист1:

Лист2:

Answer 2

Попробуйте что-то вроде этого:

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