Speeding Up a Loop in VBA

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

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 2

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

Answer 3

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.