问题
I have a data set that look like this
And i want to split it so the data becomes like this
Any vba code idea? Thank you!
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
回答1:
Try something like this:
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:
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.
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
Screenshots of Source Sheet (Sheet1) and Destination Sheet(Sheet2):
Sheet1:
Sheet2:
来源：https://stackoverflow.com/questions/61420240/split-time-range-into-half-hour-each-row