Macro Speed Up - Help

[mitko007]

Hi everybody,

i need some help on the following problem:

I have a macro which reads a range from Start Date/Time andd End Date/time a then splits this range into 1 second increments (see screenshot)



here is the code i use for doing this:

[vba]Sub AddSecsMulti()
Range("G2:G" & Range("G" & Rows.Count).End(xlUp).Row).Clear


For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
Range("G" & Rows.Count).End(xlUp).Offset(1) = Range("A" & i)
Do
With Range("G" & Rows.Count).End(xlUp)
.Offset(1) = DateAdd("s", 1, .Value)
.Offset(0, 1) = DateAdd("s", 1, .Value)
.Offset(0, 2) = Range("D" & i)
If .Value = Range("B" & i) Then .Offset(0, 1).Clear: .Offset(1).Clear: Exit Do
End With
Loop
Next i

Range("G2:G" & Range("G" & Rows.Count).End(xlUp).Row).NumberFormat = "dd.mm.yyyy hh:mm:ss"
Range("H2:H" & Range("H" & Rows.Count).End(xlUp).Row).NumberFormat = "dd.mm.yyyy hh:mm:ss"
End Sub
[/vba]
It works fine for smaller data sets, but i have to deal with large data sets and it goes to slow. Is there a way that the code can be fixed so that it works quicker. I read that VBA perfroms much better when we use Variant arrays but i'm not familiar with them

Any help will be appreciated.

Thanks

[SamT]

you are referring to Ranges and using the .End function too many times

Try this:[vba]Sub AddSecsMulti()
Dim NewSecsRng As Range
Dim StrtTimes As Range
Dim StrtSec As Long
Dim SecCnt As Long
Dim TimeCel As Range
Dim i As Long
Dim c As Long
Dim NextRow As Long
Dim Ndx As String

Application.ScreenUpdating = False
Range("G2:I" & Range("G" & Rows.Count).End(xlUp).Row).Clear
Set StrtTimes = Range("A2:" & Cells(Rows.Count, 1).End(xlUp).Address)
NextRow = 2

For Each TimeCel In StrtTimes
Ndx = TimeCel.Offset(0, 2).Text
StrtSec = TimeCel.Value
SecCnt = CLng(Format(TimeCel.Offset(0, 1).Value - StrtSec, "s"))

With Range("G" & NextRow & ":I" & NextRow + SecsCnt - 1)
For i = 1 To SecCnt
.Cells(i, 1) = DateAdd("s", i - 1, StrtSec)
.Cells(i, 2) = DateAdd("s", i, StrSec)
.Cells(i, 3) = Ndx
Next i
End With

NextRow = NextRow + SecsCnt
Next TimeCel

Range("G2:H" & Range("G" & Rows.Count).End(xlUp).Row).NumberFormat = "dd.mm.yyyy hh:mm:ss"
Application.ScreenUpdating = True
End Sub
[/vba]

[p45cal]

I read that VBA perfroms much better when we use Variant arrays

Yes, by reducing the number of write operations to the sheet can save a lot of time; instead of writing to one cell at a time, a block of cells can be written to in one line, and it's quite quick.
In the following, I've reduced the number of write operations to 2 per time block: one for the 2 columns of split times, and one for the index.
If this is still too slow, come back, because it can be tweaked so that only one write operation is needed for the whole shooting match.[VBA]Sub AddSecsMulti_pd01()
Range("G2:I" & Application.Max(2, Range("G" & Rows.Count).End(xlUp).Row)).Clear 'Contents
Set DestTop = Range("G" & Rows.Count).End(xlUp).Offset(1)
For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
StartTime = Range("A" & i).Value
EndTime = Range("B" & i).Value
ReDim RArray(1 To Round((EndTime - StartTime) * 86400, 0), 1 To 2)
J = 1
For s = StartTime To EndTime Step 1 / 86400
RArray(J, 1) = s
RArray(J, 2) = s + 1 / 86400
J = J + 1
Next s
DestTop.Resize(J - 1, 2).Value = RArray 'split times
DestTop.Offset(, 2).Resize(J - 1).Value = Range("D" & i).Value 'index
Set DestTop = DestTop.Offset(J - 1)
Next i
Range("G2:H" & Range("G" & Rows.Count).End(xlUp).Row).NumberFormat = "dd.mm.yyyy hh:mm:ss"
End Sub
[/VBA]

[jolivanes]

You could try this on a copy of your workbook also.

[VBA]Sub GetSecsBetween()
Dim rRange As Range
Dim rFill As Range
Dim dStop As Double
Dim rCell As Range

Set rRange = Range("A3", Cells(Rows.Count, 1).End(xlUp))
Application.ScreenUpdating = False
For Each rCell In rRange
dStop = rCell(1, 2)
Set rFill = Cells(3, Columns.Count).End(xlToLeft)(1, 2)
rCell.Copy rFill
Range(rFill, Cells(Rows.Count, rFill.Column)).DataSeries _
Rowcol:=xlColumns, Type:=xlLinear, _
Step:=1 / 86400, Stop:=dStop
Next rCell
Cells.Columns.AutoFit
Application.ScreenUpdating = True
End Sub[/VBA]

[mitko007]

you are referring to Ranges and using the .End function too many times

Try this:[vba]Sub AddSecsMulti()
Dim NewSecsRng As Range
Dim StrtTimes As Range
Dim StrtSec As Long
Dim SecCnt As Long
Dim TimeCel As Range
Dim i As Long
Dim c As Long
Dim NextRow As Long
Dim Ndx As String

Application.ScreenUpdating = False
Range("G2:I" & Range("G" & Rows.Count).End(xlUp).Row).Clear
Set StrtTimes = Range("A2:" & Cells(Rows.Count, 1).End(xlUp).Address)
NextRow = 2

For Each TimeCel In StrtTimes
Ndx = TimeCel.Offset(0, 2).Text
StrtSec = TimeCel.Value
SecCnt = CLng(Format(TimeCel.Offset(0, 1).Value - StrtSec, "s"))

With Range("G" & NextRow & ":I" & NextRow + SecsCnt - 1)
For i = 1 To SecCnt
.Cells(i, 1) = DateAdd("s", i - 1, StrtSec)
.Cells(i, 2) = DateAdd("s", i, StrSec)
.Cells(i, 3) = Ndx
Next i
End With

NextRow = NextRow + SecsCnt
Next TimeCel

Range("G2:H" & Range("G" & Rows.Count).End(xlUp).Row).NumberFormat = "dd.mm.yyyy hh:mm:ss"
Application.ScreenUpdating = True
End Sub
[/vba]

Hi, thanks for the reply. Unfortunately the code doesn't seen to work.

[mitko007]

Yes, by reducing the number of write operations to the sheet can save a lot of time; instead of writing to one cell at a time, a block of cells can be written to in one line, and it's quite quick.
In the following, I've reduced the number of write operations to 2 per time block: one for the 2 columns of split times, and one for the index.
If this is still too slow, come back, because it can be tweaked so that only one write operation is needed for the whole shooting match.

Hi, thanks for the code. It works fine a while and then i get the following error:




Its stops at the ranges which are only 1 sec long. (Exp: 00:00:00 - 00:00:01)

[mitko007]

You could try this on a copy of your workbook also.

[vba]Sub GetSecsBetween()
Dim rRange As Range
Dim rFill As Range
Dim dStop As Double
Dim rCell As Range

Set rRange = Range("A3", Cells(Rows.Count, 1).End(xlUp))
Application.ScreenUpdating = False
For Each rCell In rRange
dStop = rCell(1, 2)
Set rFill = Cells(3, Columns.Count).End(xlToLeft)(1, 2)
rCell.Copy rFill
Range(rFill, Cells(Rows.Count, rFill.Column)).DataSeries _
Rowcol:=xlColumns, Type:=xlLinear, _
Step:=1 / 86400, Stop:=dStop
Next rCell
Cells.Columns.AutoFit
Application.ScreenUpdating = True
End Sub[/vba]

Its looks as it works, but the problem is that it fills the splited ranges in new columns instead of below each other. And the index entries are missing as well.

[SamT]

Have you studied the three offerings to see if you can modify them to work?

When you tried p45Cal's code you said

Its stops at the ranges which are only 1 sec long. (Exp: 00:00:00 - 00:00:01)

Do you mean that you have run times that are only 1 second long? That might require special code to handle such cases.

[p45cal]

try this variation:[VBA]Sub AddSecsMulti_pd02()
Range("G2:I" & Application.Max(2, Range("G" & Rows.Count).End(xlUp).Row)).ClearContents
Set DestTop = Range("G" & Rows.Count).End(xlUp).Offset(1)
For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
StartTime = Range("A" & i).Value
endtime = Range("B" & i).Value
ReDim RArray(1 To Round((endtime - StartTime) * 86400, 0), 1 To 2)
For J = LBound(RArray) To UBound(RArray)
RArray(J, 1) = StartTime
StartTime = StartTime + 1 / 86400
RArray(J, 2) = StartTime
Next J
DestTop.Resize(J - 1, 2).Value = RArray
DestTop.Offset(, 2).Resize(J - 1).Value = Range("D" & i).Value
Set DestTop = DestTop.Offset(J - 1)
Next i
Range("G2:H" & Range("G" & Rows.Count).End(xlUp).Row).NumberFormat = "dd.mm.yyyy hh:mm:ss"
End Sub
[/VBA]

[mitko007]

try this variation:[vba]Sub AddSecsMulti_pd02()
Range("G2:I" & Application.Max(2, Range("G" & Rows.Count).End(xlUp).Row)).ClearContents
Set DestTop = Range("G" & Rows.Count).End(xlUp).Offset(1)
For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
StartTime = Range("A" & i).Value
endtime = Range("B" & i).Value
ReDim RArray(1 To Round((endtime - StartTime) * 86400, 0), 1 To 2)
For J = LBound(RArray) To UBound(RArray)
RArray(J, 1) = StartTime
StartTime = StartTime + 1 / 86400
RArray(J, 2) = StartTime
Next J
DestTop.Resize(J - 1, 2).Value = RArray
DestTop.Offset(, 2).Resize(J - 1).Value = Range("D" & i).Value
Set DestTop = DestTop.Offset(J - 1)
Next i
Range("G2:H" & Range("G" & Rows.Count).End(xlUp).Row).NumberFormat = "dd.mm.yyyy hh:mm:ss"
End Sub
[/vba]

Thanks mate, it looks as it does the job. I'll run some samples to see if there are no errors but at first glance its seem perfect.

I really appreciate your effort ,you saved me a lot of time.

Best regards !!