将时间范围分成每行半小时 [英] Split Time Range into Half Hour Each Row

问题描述

我有一个看起来像这样的数据集

I have a data set that look like this

我想将其拆分，以便数据变得像这样

And i want to split it so the data becomes like this

有任何VBA代码构想吗?谢谢！

Any vba code idea? Thank you!

我曾在另一个论坛上从用户那里尝试过此代码，但它仅显示1小时时间间隔.您能帮我把它变成30分钟的时间间隔吗?

I have tried this code from user in another forum but it only show 1 hour time interval. Could you please help me to make it become 30 min time interval?

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

推荐答案

重写您现有的代码，该代码已经过测试并且可以工作.可读性要容易得多，使用描述性的变量名，可以更轻松地看到每一行的内容.

Rewriting your existing code, this is tested and works. Readability is much easier and with descriptive variable names it's easier to see what each line is doing.

注意::这只会找到1小时之间的半小时间隔.例如，如果开始时间为09:00，结束时间为11:00，则只会返回09:00和09:30的时间.

Note: This will only find half hour intervals between 1 hour. If for example the start time is 09:00 and the end time is 11:00 it would only return the times for 09:00 and 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 )的屏幕截图:

Screenshots of Source Sheet (Sheet1) and Destination Sheet(Sheet2):

这篇关于将时间范围分成每行半小时的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！