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

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
– Scott Craner, Commented Mar 19, 2020 at 16:29
@ScottCraner that is disappointing. Sorry to waste your time Shaves — urdearboy
– urdearboy, Commented Mar 19, 2020 at 16:29
@urdearboy......no worries.....it was a learning experience; which is never a bad thing. Thanks for your help....... — Shaves
– Shaves, Commented Mar 19, 2020 at 19:44

marc_s · Accepted Answer · 2023-12-12 10:24:06Z

2

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 different 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:

edited Dec 12, 2023 at 10:24

marc_s

760k186 gold badges1.4k silver badges1.5k bronze badges

answered Mar 19, 2020 at 17:59

Dang D. Khanh

1,4618 silver badges13 bronze badges

Sign up to request clarification or add additional context in comments.

2 Comments

Scott Craner Over a year ago

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.

Dang D. Khanh Over a year ago

Hi, @ScottCraner: yes, that is quite possible ^^

Scott Craner · Accepted Answer · 2020-03-19 16:47:38Z

1

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

answered Mar 19, 2020 at 16:47

Scott Craner

153k10 gold badges52 silver badges88 bronze badges

1 Comment

Shaves Over a year ago

@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

Collectives™ on Stack Overflow

VBA code to insert blank rows doesn't always work

2 Answers 2

2 Comments

1 Comment

Your Answer

Linked

Hot Network Questions

Collectives™ on Stack Overflow

2 Answers 2

2 Comments

1 Comment

Your Answer

Sign up or log in

Post as a guest

Linked

Related