VBA code to insert blank rows doesn't always work

Question

I'm trying to insert a blank row between 2 rows if the values in A1 <> A2. I was given the code below and it works if the data looks like this a,a,b,b,c,c,d,d,e,e,f,f,g,g,h,h,i,i. The results are exactly what I'm looking for: a, blank row, a, blank row, b blank row, b, blank row, c, blank row, c, etc.

However, if the data looks like this a,b,c,d,e,f,g,h,i then I get 8 blank rows between a and b but none anywhere else.

Any ideas why this is happening like this?

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

Original post is [here](https://stackoverflow.com/questions/60747068/excel-vba-to-insert-blank-rows-is-taking-too-long/60747314?noredirect=1#comment107502610_60747314). I was not able to de-bug :( — urdearboy, Mar 19 '20 at 16:28
This approach will not work when the data is singular, because VBA sees `Rows("1:2")` as a single range not two areas. You will need to go with the other approach by using a helper column. — Scott Craner, Mar 19 '20 at 16:29
@ScottCraner that is disappointing. Sorry to waste your time Shaves — urdearboy, Mar 19 '20 at 16:29
@urdearboy......no worries.....it was a learning experience; which is never a bad thing. Thanks for your help....... — Shaves, Mar 19 '20 at 19:44

score 2 · Answer 1 · answered Mar 19 '20 at 17:59

Maybe this is what you need, It works well with different consecutive value cases:

Note: when two consecutive cells (in the same column) are added, it will be treated as one cell (this is how union works) so you will get the Position of another Cell in the same Row but diferrent Column, now the result: union = yellow range [see an image]

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
k = 1
Dim cell As Range
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, k)): k = k + 1 'increase column index
        Else
            Set MyUnion = xCell.Offset(1, 0)
        End If
    End If
Next xCell
If Not MyUnion Is Nothing Then MyUnion.EntireRow.Insert Shift:=xlDown
End Sub

For example:

This is great, as long as there are not more than 16384 breaks needed. :) I guess one can use `Mod` to start over if that was exceeded. Or simply use `Mod 3` as long as the cells do not exist right below or right next to the other. — Scott Craner, Mar 19 '20 at 18:36

score 1 · Answer 2 · answered Mar 19 '20 at 16:47

this uses a helper column and sorting to put in blank rows:

Sub Social_Distance()

    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("Sheet14")'change to your sheet

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

    Dim rngArr As Variant
    rngArr = ws.Range(ws.Cells(1, 1), ws.Cells(lr, 1)).Value

    Dim rowArr() As Variant
    ReDim rowArr(1 To lr - 1, 1 To 1)

    Dim x As Double
    x = 0#

    Dim i As Long
    For i = 2 To lr
        If rngArr(i, 1) <> rngArr(i - 1, 1) Then x = x + 1
        rowArr(i - 1, 1) = x
    Next i

    Dim newLineArray() As Variant
    ReDim newLineArray(1 To Int(x - 1), 1 To 1)

    For i = 1 To Int(x - 1)
        newLineArray(i, 1) = CDbl(i) + 0.1
    Next i

    ws.Columns(1).Insert
    ws.Range("A1").Value = "Temp"
    ws.Range("A2").Resize(lr - 1).Value = rowArr
    ws.Range("A" & lr + 1).Resize(Int(x - 1)).Value = newLineArray

    ws.UsedRange.Sort key1:=ws.Range("A1"), Header:=xlYes

    ws.Columns(1).Delete

End Sub

@scottcramer.....thanks for all of the help. I ended up using a couple of columns and adding blank rows at the bottom and then resorting. It went from 12 minutes to 4 - 5 seconds. Thanks again — Shaves, Mar 19 '20 at 19:48

VBA code to insert blank rows doesn't always work

2 Answers2