Excel vba to Insert blank rows is taking too long

Question

I have a macro that is comparing 2 cells and inserting a blank row between them if they are different. It was taking about 12 minutes to complete this process with this code:

    Worksheets("Dollars").Activate
    Range("B10").Select

'    Do Until ActiveCell.Formula = ""
'        DoEvents
'        If ActiveCell <> ActiveCell.Offset(1, 0) Then
'            ActiveCell.Offset(1, 0).Activate
'            Selection.EntireRow.Insert
'        End If
'        ActiveCell.Offset(1, 0).Activate
'    Loop

I rewrote the code to this way to see if it was any better and it still took over 12 minutes to run.

    Dim r As Long
    Dim vStr1 As String
    Dim vStr2 As String
    r = 10
    vStr1 = ""
    vStr2 = ""

    Do Until Len(Trim(Cells(r, 2))) = 0
        DoEvents
        vStr1 = ""
        vStr2 = ""
        vStr1 = Trim(Cells(r, 2))
        vStr2 = Trim(Cells((r + 1), 2))

        If vStr1 = vStr2 Then
'           do nothing
        Else
            Cells((r + 1), 1).EntireRow.Select
            Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
            r = r + 1
        End If
        r = r + 1
    Loop

is there a better way to do this so it doesn't take so long? We are using Windows 10 and Office 2016. Thanks for the help. I appreciate it....

You want to loop from the bottom up if you're inserting rows. Also, [don't Select](https://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba). — BigBen, Mar 18 '20 at 20:31
Can you show sample data? You can do this with a `UNION` I believe but don't want to write up a solution before seeing a before and after — urdearboy, Mar 18 '20 at 20:44
Union is the way to go. Loop the data and create a uionized range of the rows to add. then add at once. — Scott Craner, Mar 18 '20 at 20:46
Possible quick win: turn off screenupdating and set calc to manual — iDevlop, Mar 18 '20 at 20:57
@PatrickHonorez the screenupdating will only make a small increase, as is usually considered a sloppy fix. The idea should be to fix the code in a way that that the code references the sheet minimally. — Scott Craner, Mar 18 '20 at 20:59
@ScottCraner - disagree on the "sloppy" for ScreenUpdating - that's a perfectly valid thing to do if you *have* to make a lot of updates, and there are no trade-offs/downsides to using it that I can think of. — Tim Williams, Mar 18 '20 at 21:01
@ScottCraner AFAIK the screenupdating is specially interesting on row/column insert. For the rest 1) I am too tired, 2) I think the underlying algorithm is just bad. I would probably suggest the OP to add data at end of list and sort everything afterwards. But I don't know enough of the context. — iDevlop, Mar 18 '20 at 21:07
I am not saying it is bad, but as a silver bullet to speed up code, it is little like, "putting lipstick on a pig". I use it when I need it, but it is not as a cure all. — Scott Craner, Mar 18 '20 at 21:09
@PatrickHonorez......the macro does some stuff before the code I showed and it takes not time at all. Screenupdating is turned off at the beginning of the code. — Shaves, Mar 18 '20 at 21:10
@TimWilliams.....There are 2,900 rows of data and it is adding a blank row between virtually every 2 cells. The overwhelming of the comparisions do not match so a blank row is added each time. — Shaves, Mar 18 '20 at 21:12
@TimWilliams....There are actually 2,400 rows of data. Upon further review, there are 3 blank rows after row 1,915 (if that makes adifference — Shaves, Mar 18 '20 at 21:20
@ScottCraner haha!! I will remember the 'lipstick on a pig'. Good one :-) — iDevlop, Mar 19 '20 at 14:12

score 1 · Answer 1 · answered Mar 18 '20 at 20:51

1

Assuming you only care if A1 <> A2 and so on until the end of your range.... you can use a Union to gather up target cells where you want your rows to be inserted. Then, insert the rows all at once at the end rather doing so line by line. Notice that nothing needs to be selected as stated by @BigBen

Sub Social_Distance()

Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet2")

Dim lr As Long, MyUnion As Range, xCell As Range
lr = ws.Range("A" & ws.Rows.Count).End(xlUp).Row

For Each xCell In ws.Range("A2:A" & lr)
    If xCell.Value <> xCell.Offset(1).Value Then
        If Not MyUnion Is Nothing Then
            Set MyUnion = Union(MyUnion, xCell.Offset(1))
        Else
            Set MyUnion = xCell.Offset(1)
        End If
    End If
Next xCell

If Not MyUnion Is Nothing Then MyUnion.EntireRow.Insert Shift:=xlDown

End Sub

answered Mar 18 '20 at 20:51

urdearboy

14,439
5
28
58

@urdearboy...............Thanks............It has to compare each cell to the one below it. A1<> A2, A2 <> A3, A3 <> A4, etec.....and then insert a blank between any 2 cells that dont match... – Shaves Mar 18 '20 at 21:08
Correct - that’s what is happening here :) – urdearboy Mar 18 '20 at 21:12
@urdearboy......I added the code as is and ran the macro., I got 1900 blank rows between the what was the first and second cells. No blank rows between the rest of the data – Shaves Mar 18 '20 at 21:17
I tested this on `Column A` for me using data `a, a, a, b, b, c, c, c, c, d, d, e, e, e, f` and this created a space between each new letter effectively creating groupings of letters – urdearboy Mar 18 '20 at 21:44
@urdearboy - I'd have thought that works but try it with a,b,c,d,e,f,g. – SJR Mar 19 '20 at 10:52
@urdearboy.......there are very few duplicates in the data.....it's more like a, b,c, d, e, f, g, h, i..... – Shaves Mar 19 '20 at 14:36
@SJR............I think the issue is related to the data. When I use a,a,b,b,c,c,d,d,e,e,f,f,g,g.....it works like a champ. When I try a,b,c,d,e,f,g,h.......I get only get blank rows between a and b..... – Shaves Mar 19 '20 at 15:06
hmmm - the issue is not immediately obvious to me but I am swamped today. This seems to work for one data set and break for another @Shaves - you can definitely take this solution and turn it into a new question. Show examples of what you want the code to do and then show data that this fails on. I'm sure people much smarter than me can figure this one out really quickly – urdearboy Mar 19 '20 at 15:11
@SJR - thanks for giving example of break. I don't have time to de-bug today :( recommending OP turn this solution to a post – urdearboy Mar 19 '20 at 15:13
@urdearboy.......Thanks..........I'll try that. Thanks for the help – Shaves Mar 19 '20 at 16:07

score 1 · Answer 2 · answered Mar 19 '20 at 15:36

1

This will not be tremendously quick, but should do the job.

Sub x()

Dim r As Long

Application.ScreenUpdating = False

With Worksheets("Dollars")
    For r = .Range("B" & Rows.Count).End(xlUp).Row To 10 Step -1
        If .Cells(r, 2).Value <> .Cells(r - 1, 2).Value Then
            .Cells(r, 2).EntireRow.Insert
        End If
    Next r
End With

Application.ScreenUpdating = True

End Sub

answered Mar 19 '20 at 15:36

SJR

22,986
6
18
26

2

This is the correct way to do this (loop backwards) but I don’t believe this will address the speed issue. Will prob take just as long, although at least it will be correct :) lol – urdearboy Mar 19 '20 at 16:09

score 0 · Accepted Answer · answered Mar 19 '20 at 14:17

0

Generally speaking inserting a lot of rows in Excel is a PITA performance wise.
You should consider adding rows at the end of your list and sorting the whole list at the end of the process.
I know it's a bit short answer but it's all I can do from my Chromebook now...

answered Mar 19 '20 at 14:17

iDevlop

24,841
11
90
149

@patrickhonorez....I agree.....I'll give that a try and see how it works for me.....Thanks – Shaves Mar 19 '20 at 14:37
1

@patrickhomorez.........I used your suggestion and it worked for me. The old process was taking over 12 minutes and now it takes 4 - 5 seconds. Thanks for the suggestion..... – Shaves Mar 19 '20 at 19:54

Excel vba to Insert blank rows is taking too long

3 Answers3

Linked