Speeding Up a Loop in VBA - excel

Question

I am trying to speed up a loop in VBA with over 25,000 line items
I have code that is stepping down through a spread sheet with over 25,000 lines in it. Right now the code loops thought each cell to see if the Previous cell values match the current cell values. If they do not match it inserts a new blank line. Right now the code take over 5 hours to complete on a pretty fast computer. Is there any way I can speed this up?
With ActiveSheet
BottomRow4 = .Cells(.Rows.Count, "E").End(xlUp).Row
End With
Do
Cells(ActiveCell.Row, 5).Select
Do
ActiveCell.Offset(1, 0).Select
'Determines if previous cells is the same as current cells
Loop Until (ActiveCell.Offset(0, -1) & ActiveCell <>
ActiveCell.Offset(1, -1) & ActiveCell.Offset(1, 0))
'Insert Blank Row if previous cells do not match current cells...
Rows(ActiveCell.Offset(1, 0).Row & ":" & ActiveCell.Offset(1,
0).Row).Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
BottomRow4 = BottomRow4 + 1
Loop Until ActiveCell.Row >= BottomRow4

Answer 1

Similarly to when deleting rows, you can save your inserts until you're done looping.
Run after selecting a cell at the top of the column you want to insert on (but not on row 1):
Sub Tester()
Dim c As Range, rngIns As Range, sht As Worksheet
Dim offSet As Long, cInsert As Range
Set sht = ActiveSheet
For Each c In sht.Range(Selection, _
sht.Cells(sht.Rows.Count, Selection.Column).End(xlUp)).Cells
offSet = IIf(offSet = 0, 1, 0) '<< toggle offset
If c.offSet(-1, 0).Value <> c.Value Then
'This is a workaround to prevent two adjacent cells from merging in
' the rngInsert range being built up...
Set cInsert = c.offSet(0, offSet)
If rngIns Is Nothing Then
Set rngIns = cInsert
Else
Set rngIns = Application.Union(cInsert, rngIns)
End If
End If
Next c
If Not rngIns Is Nothing Then
rngIns.EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
End If
End Sub
Edit: runs in 3 secs on 25k rows populated using ="Val_" & ROUND(RAND()*1000), converted to values, then sorted.

Answer 2

Insert If Not Equal
Sub InsertIfNotEqual()
Const cSheet As Variant = 1 ' Worksheet Name/Index
Const cFirstR As Long = 5 ' First Row
Const cCol As Variant = "E" ' Last-Row-Column Letter/Number
Dim rng As Range ' Last Cell Range, Union Range
Dim vntS As Variant ' Source Array
Dim vntT As Variant ' Target Array
Dim i As Long ' Source Array Row Counter
Dim j As Long ' Target Array Row Counter
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
On Error GoTo ProcedureExit
' In Worksheet
With ThisWorkbook.Worksheets(cSheet)
' Determine the last used cell in Last-Row-Column.
Set rng = .Columns(cCol).Find("*", , xlFormulas, , , xlPrevious)
' Copy Column Range to Source Array.
vntS = .Cells(cFirstR, cCol).Resize(rng.Row - cFirstR + 1)
End With
' In Arrays
' Resize 1D Target Array to the first dimension of 2D Source Array.
ReDim vntT(1 To UBound(vntS)) As Long
' Loop through rows of Source Array.
For i = 2 To UBound(vntS)
' Check if current value is equal to previous value.
If vntS(i, 1) <> vntS(i - 1, 1) Then
' Increase row of Target Array.
j = j + 1
' Write Source Range Next Row Number to Target Array.
vntT(j) = i + cFirstR
End If
Next
' If no non-equal data was found.
If j = 0 Then Exit Sub
' Resize Target Array to found "non-equal data count".
ReDim Preserve vntT(1 To j) As Long
' In Worksheet
With ThisWorkbook.Worksheets(cSheet)
' Set Union range to first cell of row in Target Array.
Set rng = .Cells(vntT(1), 2)
' Check if there are more rows in Target Array.
If UBound(vntT) > 1 Then
' Loop through the rest of the rows (other than 1) in Target Array.
For i = 2 To UBound(vntT)
' Add corresponding cells to Union Range. To prevent the
' creation of "consecutive" ranges by Union, the resulting
' cells to be added are alternating between column A and B
' (1 and 2) using the Mod operator against the Target Array
' Row Counter divided by 2.
Set rng = Union(rng, .Cells(vntT(i), 1 + i Mod 2))
Next
End If
' Insert blank rows in one go.
rng.EntireRow.Insert
End With
ProcedureExit:
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub

Answer 3

Edited: Added two options: didn't test for speed. I thought test2() would have been faster but I'm not certain depending on number of rows.
Untested, but just something I thought of quickly. If I'll remember I'll come back to this later because I think there are faster ways
Sub Test1()
Dim wsSheet As Worksheet
Dim arrSheet() As Variant
Dim collectRows As New Collection
Dim rowNext As Long
Application.ScreenUpdating = False
Application.EnableEvents = False
Const ColCheck As Integer = 6
Set wsSheet = ActiveSheet
arrSheet = wsSheet.Range("A1").CurrentRegion
For rowNext = UBound(arrSheet, 1) To LBound(arrSheet, 1) + 1 Step -1
If arrSheet(rowNext, ColCheck) <> arrSheet(rowNext - 1, ColCheck) Then collectRows.Add rowNext
Next rowNext
For rowNext = 1 To collectRows.Count
wsSheet.Cells(collectRows(rowNext), 1).EntireRow.Insert
Next rowNext
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Second Option inserting all at once:
I used a string here because union would change rows next to each other into one larger range. Instead of Range("1:1", "2:2") it would create ("1:2") and that won't insert the way you need. I don't know of a cleaner way, but there probably is.
Sub Test2()
Dim wsSheet As Worksheet
Dim arrSheet() As Variant
Dim collectRows As New Collection
Dim rowNext As Long
Dim strRange As String
Dim cntRanges As Integer
Dim rngAdd As Range
Application.ScreenUpdating = False
Application.EnableEvents = False
Const ColCheck As Integer = 6
Set wsSheet = ActiveSheet
arrSheet = wsSheet.Range("A1").CurrentRegion
For rowNext = UBound(arrSheet, 1) To LBound(arrSheet, 1) + 1 Step -1
If arrSheet(rowNext, ColCheck) <> arrSheet(rowNext - 1, ColCheck) Then
strRange = wsSheet.Cells(rowNext, 1).EntireRow.Address & "," & strRange
cntRanges = cntRanges + 1
If cntRanges > 10 Then
collectRows.Add Left(strRange, Len(strRange) - 1)
strRange = vbNullString
cntRanges = 0
End If
End If
Next rowNext
If collectRows.Count > 0 Then
Dim i As Long
For i = 1 To collectRows.Count
Set rngAdd = Range(collectRows(i))
rngAdd.Insert
Next i
End If
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub