VBA to insert blank row after repeating cell values in a column

[KP_SoCal]

In Column A, I have several repeating cell values. I would l like to insert a blank row at point the value changes into a new set of repeating values. The illustration below should better illustrate what I’m trying to get at.

Before code execution…
A1: Title
A2: Apple
A3: Apple
A4: Apple
A5: Pear
A6: Pear
A7: Orange
A8: Orange
A9: Orange


AFTER code execution…
A1: Title
A2: Apple
A3: Apple
A4: Apple
A5:
A6: Pear
A7: Pear
A8:
A9: Orange
A10: Orange
A11: Orange

Here’s a nice link that points me in the general direction of what I need, but I can’t figure out how to tailor it to my specific needs. Thanks for any suggestions!

 

[Jazzed]

Try...

Sub InsertBlankRows()

Dim LastRow As Long
Dim i As Long

LastRow = Cells(Rows.Count, "A").End(xlUp).Row

For i = LastRow To 2 Step -1
    If i = 2 Then
        'Do nothing
    ElseIf Cells(i, "A") <> Cells(i - 1, "A") Then
        Cells(i, "A").Insert
    End If
Next i

End Sub

 

[Peter_SSs]

Here's a method that doesn't involve looping through the rows individually. I think it should do what you want.

Sub InsertRows()
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  With Range("A1", Range("A" & Rows.Count).End(xlUp))
    .Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(1), _
    Replace:=True, PageBreaks:=False, SummaryBelowData:=True
    .Offset(, -1).AutoFilter Field:=1, Criteria1:="=*total*"
    .Offset(2).SpecialCells(xlCellTypeVisible).ClearContents
    .AutoFilter
    .Offset(, -1).EntireColumn.Delete
    .EntireColumn.RemoveSubtotal
  End With
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
End Sub

 

[KP_SoCal]

Hats off to both of you guys! I really appreciate it. Both of these examples worked!

Cheers!!!



KP

 

[Peter_SSs]

Just realised, that mine doesn't actually need to do the AutoFilter. So this version should be even faster, though speed probably won't be an issue for you anyway unless your dataset is large.

Sub InsertRows()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With Range("A1", Range("A" & Rows.Count).End(xlUp))
.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(1), _
Replace:=True, PageBreaks:=False, SummaryBelowData:=True
.Offset(2, -1).SpecialCells(xlCellTypeConstants).Offset(, 1).ClearContents
.Offset(, -1).EntireColumn.Delete
.EntireColumn.RemoveSubtotal
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

 

[KP_SoCal]

Peter, thanks so much for this.

I will definitely apply the second set of code you provided then.

KP

 

[Jazzed]

With regards to the solution I offered, to insert an entire blank row, not just a blank cell, replace...

Cells(i, "A").Insert

with

Cells(i, "A").EntireRow.Insert

 

[Peter_SSs]

With regards to the solution I offered, to insert an entire blank row, not just a blank cell, replace...

Cells(i, "A").Insert

with

Cells(i, "A").EntireRow.Insert

Or just

Rows(i).Insert

 

[Jazzed]

Or just

Rows(i).Insert

Thanks Peter!

 

[upan275]

Try...

Sub InsertBlankRows()
 
Dim LastRow As Long
Dim i As Long
 
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
 
For i = LastRow To 2 Step -1
    If i = 2 Then
        'Do nothing
    ElseIf Cells(i, "A") <> Cells(i - 1, "A") Then
        Cells(i, "A").Insert
    End If
Next i
 
End Sub

how can i do the same code for the Two columns?
i.e.
ElseIf Cells(i, "A") <> Cells(i - 1, "A") Then
Cells(i, "A").EntireRow.Insert

Also do the same for Column "C"
ElseIf Cells(i, "C") <> Cells(i - 1, "C") Then
Cells(i, "C").EntireRow.Insert

BUT I don't want more than one blank row after applying Both Logic
hence
May be,IF there are Two consequtive Blank Row delete all extra & keep one only???