|
在原工作簿中增加一个Sheet2工作表,然后在Sheet1工作表下写入如下代码:
- Sub test()
- Dim arr, brr(1 To 10000, 1 To 4)
- Dim bdate As Date, edate As Date
- Dim i&, n&, last&
- Dim t1d$, t2d$
- ThisWorkbook.Sheets("Sheet2").Cells.Clear
- With ThisWorkbook.Sheets("Sheet1")
- last = .[a65536].End(3).Row
- ThisWorkbook.Sheets("Sheet2").Range("a1:v1").Value = .Range("a1:v1").Value
- For i = 2 To last
- arr = .Range("a" & i & ":v" & i)
- bdate = arr(1, 13) & " " & arr(1, 14)
- edate = arr(1, 15) & " " & Format(arr(1, 16), "hh:mm")
- n = 0
- Do While bdate < edate
- n = n + 1
- t1d = Format(bdate, "yyyy/mm/dd hh:mm")
- brr(n, 1) = Split(t1d, " ")(0)
- brr(n, 2) = Split(t1d, " ")(1)
- t2d = IIf(Int(bdate) + 1 < edate, Format(Int(bdate) + 1, "yyyy/mm/dd hh:mm"), Format(edate, "yyyy/mm/dd hh:mm"))
- brr(n, 3) = Split(t2d, " ")(0)
- brr(n, 4) = Split(t2d, " ")(1)
- bdate = t2d
- Loop
- With ThisWorkbook.Sheets("Sheet2")
- last = .[a65536].End(3).Row
- .Range("a" & last + 1 & ":v" & last + n) = arr
- .Range("m" & last + 1).Resize(n, 4) = brr
- End With
- Erase brr
- Next i
- End With
复制代码
|
|