Inserting blank rows now running very slow

This block of code inserts a blank row at every change in column A. The loop begins at the bottom. This used to run extremely fast. Now it's slow. Any ideas why?

   Dim firstRow As Integer
    Dim currentRow As Integer
    
    firstRow = 2
  
    
    For currentRow = Range("A1048576").End(xlUp).Row To firstRow Step -1
        If Range("A" & currentRow) <> Range("A" & currentRow).Offset(-1, 0) Then
           Range("A" & currentRow).EntireRow.Insert
        End If
    
    Next

There is other code in this procedure. For some reason it takes a long time. When I run this code in its own procedure it zips right thru.

Originally Posted by Trebor76

From Excel 2007 and on it's a good idea to not use an integer variable when referencing rows as its highest value is 32,767 as opposed to there being 1,048,576 rows in Excel 2007 and on.
Robert

Nice suggestion. I didn't even think about that. I hope I will keep that in mind.

I tried your code and it still takes the same amount of time to execute. Any other ideas? Does memory need to be cleared out or something?

Also, I noticed that in your code you turn off/then turn on screen updating. Is there an advantage to doing this?

Originally Posted by Excel_vba

This block of code inserts a blank row at every change in column A.

The way the question is posted might be an event code? If thats the case I would just add one more thing to the amazing code Trebor76 provided.

Option Explicit
Sub Macro1()

    Dim lngMyRow As Long
    Dim xlnCalcMethod As XlCalculation
    
    With Application
        xlnCalcMethod = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    
    For lngMyRow = Cells(Rows.Count, "A").End(xlUp).Row To 2 Step -1
        If Range("A" & lngMyRow) <> Range("A" & lngMyRow).Offset(-1, 0) Then
           Range("A" & lngMyRow).EntireRow.Insert
        End If
    Next lngMyRow
    
    With Application
        .Calculation = xlnCalcMethod
        .ScreenUpdating = True
        .EnableEvents = True
    End With

End Sub

Thanks

Originally Posted by fredlo2010

The way the question is posted might be an event code? If thats the case I would just add one more thing to the amazing code Trebor76 provided.

What do you mean by event code?

A code thats controlled by and event is placed under the Sheet module or Thisworkbook. They are triggered by changes in the worksheet. For example if the even is triggered every time the sheet is calculated the code will run.

Did you tried my code? Can you provide us with a sample of the workbook ?

The code Trebor provided turns off calculations (set them to manual , and then back to whatever state it was on) so the formulas do not have to refresh and use memory. It also turns off screen updating so it does not use as much memory repainting and showing updated material.

At this point the code should be bulletproof lol can you attach a sample of your workbook. Maybe there is something we are missing.

Thanks


Thanks

Try this

Sub test()
    Application.ScreenUpdating = False
    Columns(1).Insert
    With Range("b3", Range("b" & Rows.Count).End(xlUp)).Offset(, -1)
        .Formula = "=if(b2<>b3,if(a2=1,""a"",1),"""")"
        .Value = .Value
        On Error Resume Next
        .SpecialCells(2, 1).EntireRow.Insert
        .SpecialCells(2, 2).EntireRow.Insert
        On Error GoTo 0
    End With
    Columns(1).Delete
    Application.ScreenUpdating = True
End Sub

Just for the heck of it.
Don't take this wrong please as I certainly can't compete writing code with you people.
Filled 50,000 rows in blocks of 10, (every 10th row the value changes).
Ran all three codes twice each with a timer and got the following.
Trebor76 first code, resp. 16.05 and 14.17 seconds
Trebor76 second code (the code from fredlo2010's post) resp 11.61 and 12.36 seconds
jindon's code resp 19.48 and 20.56 seconds.
This is on a +/- 7 year old machine with 2 GB Ram and a 2.4 GHz CPU.

Try this one then

Sub test()
    Dim a, e, n As Long, x As Long, s
    s = Timer
    Application.ScreenUpdating = False
    With Cells(1).CurrentRegion
        a = .Columns(1).Resize(.Rows.Count * 2, 1).Value
        x = .Rows.Count
        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1
            For Each e In a
                If e <> "" Then
                    If Not .exists(e) Then
                        n = n + 1: .Item(e) = Empty
                        a(x + n, 1) = e
                    End If
                End If
            Next
        End With
        With .Resize(x + n, .Columns.Count + 1)
            .Columns(.Columns.Count).Value = a
            .Sort .Cells(2, .Columns.Count), 1, Header:=xlNo
            .Columns(.Columns.Count).EntireColumn.Delete
        End With
    End With
    Application.ScreenUpdating = True
    MsgBox Timer - s
End Sub

OK Gentlemen, here is what I got. (see attached as your machine is probably from this century)

Trebor76 (Post #2) resp 11.70 and 9.86 seconds
Trebor76 (Post #2, with suggestion fredlo 2010) resp 13.05 and 14.84 seconds
Trebor76 (Post #10, with suggestion fredlo 2010) resp 16.66 and 18.52 seconds
jindon (Post #7) resp 27.06 and 29.86 seconds
jindon (Post #12) resp 0.39 and 0.39 seconds
kalak (Post #11) resp 0.61 and 0.61 seconds