Increase looping speed

[davahill]

Hi,

Is there a faster way to perform the following task instead of looping. I've got anywhere from 10,000 to 50,000 unique records.

Sub InsertBlankAtChange()
Dim LastRow As Long
Dim i As Long
LastRow = Cells(Cells.Rows.Count, "G").End(xlUp).Row
For i = LastRow To 2 Step -1
If Cells(i, "G").Value <> Cells(i - 1, "G").Value Then Rows(i).Insert
Next i
End Sub

Thank you in adbvence.

 

[Jonmo1]

I think that's pretty much as good as you can get for the code.

However, you can improve speed by turning off Calculations / Events / ScreenUpdating

Dim PrevCalc As Variant

With Application
    .ScreenUpdating = False
    .EnableEvents = False
    PrevCalc = .Calculation
    .Calculation = xlCalculationManual
End With

'rest of your code here

With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = PrevCalc
End With

 

[mirabeau]

Hi,

Is there a faster way to perform the following task instead of looping. I've got anywhere from 10,000 to 50,000 unique records.

...

Thank you in adbvence.

I believe there's no non-looping approach that does it faster.

But you can use a much faster loop, albeit somewhat more complex code.

Sub blank_if_change()

Dim r As Long, c As Long, a, u(), i As Long, k as Long
r = Cells.Find("*", , , , xlByRows, xlPrevious).Row
c = Cells.Find("*", , , , xlByColumns, xlPrevious).Column
ReDim u(1 To r, 1 To 1)
a = Cells(1, "g").Resize(r + 1)
Application.ScreenUpdating = False
Cells(c + 1) = 1: Cells(c + 1).Resize(r).DataSeries

For i = 1 To r
    If a(i, 1) <> a(i + 1, 1) Then k = k + 1: u(k, 1) = i
Next i

Cells(r + 1, c + 1).Resize(k) = u
Cells(1).Resize(r + k, c + 1).Sort Cells(c + 1), Header:=xlNo
Cells(c + 1).Resize(r + k).ClearContents
Application.ScreenUpdating = True

End Sub

 

[davahill]

Thank you both. They are both an improvement from my original code.

 

[davahill]

mirabeau, would it be possible to increase the size (height) of the blank row by a factor of two or twice as tall as it would normally be?

Thank you in advance for your response.

 

[mirabeau]

mirabeau, would it be possible to increase the size (height) of the blank row by a factor of two or twice as tall as it would normally be?

Thank you in advance for your response.

taking "as tall as it would normally be" as the height of the first row on your worksheet, then add the three red lines to the code

Sub blank_if_change()

Dim r As Long, c As Long, a, u(), i As Long, k As Long
r = Cells.Find("*", , , , xlByRows, xlPrevious).Row
c = Cells.Find("*", , , , xlByColumns, xlPrevious).Column
ReDim u(1 To r, 1 To 1)
a = Cells(1, "g").Resize(r + 1)
Application.ScreenUpdating = False
Cells(c + 1) = 1: Cells(c + 1).Resize(r).DataSeries

For i = 1 To r
    If a(i, 1) <> a(i + 1, 1) Then k = k + 1: u(k, 1) = i
Next i

Cells(r + 1, c + 1).Resize(k) = u
Cells(1).Resize(r + k, c + 1).Sort Cells(c + 1), Header:=xlNo
Cells(c + 1).Resize(r + k).ClearContents

For i = 1 To k - 1
    Rows(u(i, 1) + i).RowHeight = 2 * Rows(1).RowHeight
Next i

Application.ScreenUpdating = True

End Sub

If you mean twice the Excel default row height, in my 2007 Excel this is 15. So you could replace the second red line by ... = 30

 

[Blade Hunter]

Just throwing an idea out there which unfortunately I don't currently have the time to explore but maybe one of the other guys on here can. How about you loop the values and build an array for the range or rows that need the insert then do all the inserts in one go, this would save a massive amount of time I believe.