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!

 

[Scarbo]

Thanks so much Peter! This works great - I ended up with this:

Sub InsertSubtotals()

Application.ScreenUpdating = False
Application.DisplayAlerts = False
ThisWorkbook.Sheets(sheet_I_Onshore_DTB_YTD).Select
ThisWorkbook.Sheets(sheet_I_Onshore_DTB_YTD).Range("A1", Range("A" & Rows.Count).End(xlUp)).Resize(, 18) _
.Subtotal _
GroupBy:=1, Function:=xlSum, TotalList:=Array(1, 10, 11, 13), _
Replace:=True, PageBreaks:=False, SummaryBelowData:=True
With Range("A1", Range("A" & Rows.Count).End(xlUp).Offset(-1)).SpecialCells(xlConstants)
With .EntireRow.Font
.Bold = True
.ColorIndex = xlAutomatic
.TintAndShade = 0
End With
With .EntireRow.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With .EntireRow.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With .EntireRow.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With .EntireRow.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With .EntireRow.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 14671839
.TintAndShade = 0
.PatternTintAndShade = 0
End With

.Offset(, 1).FormulaR1C1 = "=""Subtotal: "" & R[-1]C"
Columns("A").Delete
Columns("A").RemoveSubtotal
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

A very small point - is there a way to limit the formatting to columns A through R. Using .EntireRow obviously applies the borders and colours etc across the whole sheet to column XFD

I was thinking of using something like this afterwards but perhaps you know a neater way?

Sub Removeformatting()

ThisWorkbook.Sheets(sheet_I_Onshore_DTB_YTD).Select
Columns("S:S").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Selection.Font.Bold = False
With Selection.Font
.ColorIndex = xlAutomatic
.TintAndShade = 0
End With
End Sub


Thanks again.

 

[Peter_SSs]

When posting code, please use one of the methods suggested in my signature block. In my previous post here I used the VBHTMLMaker and this time I am usuing Code Tags (this is the easiest method to start with). Reading and debugging code that is all left-aligned is much more difficult. Compare your post code to mine. You'll get a lot more potential helpers if you post indented code since it is easier to see where blocks of code start/finish.

A very small point - is there a way to limit the formatting to columns A through R. Using .EntireRow obviously applies the borders and colours etc across the whole sheet to column XFD

I was thinking of using something like this afterwards but perhaps you know a neater way?

I've re-worked the code to do this. Note also, the greatly reduced 'borders' section (one line) by using the BorderAround method (have a look in the vba Help about this)

There is generally no need to select things to work with them in vba and selecting slows your code. So I have removed the 'selection' of the 'sheet_I_Onshore_DTB_YTD' sheet to demonstrate but you can add the selection back in if you really do want to have that sheet selected when the code has finished.

Anyway, see if this is closer to the mark

Sub InsertSubtotals_v2()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    With ThisWorkbook.Sheets(sheet_I_Onshore_DTB_YTD)
        .Range("A1", .Range("A" & .Rows.Count).End(xlUp)).Resize(, 18).Subtotal _
                GroupBy:=1, Function:=xlSum, TotalList:=Array(1, 10, 11, 13), _
                Replace:=True, PageBreaks:=False, SummaryBelowData:=True
        With Intersect(.Range("A1", .Range("A" & .Rows.Count).End(xlUp).Offset(-1)) _
                .SpecialCells(xlConstants).EntireRow, .Columns("A").Resize(, 19))
            With .Font
                .Bold = True
                .ColorIndex = xlAutomatic
                .TintAndShade = 0
            End With
            .BorderAround LineStyle:=xlContinuous, Weight:=xlMedium, ColorIndex:=0
            With .Interior
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .Color = 14671839
                .TintAndShade = 0
                .PatternTintAndShade = 0
            End With
            Intersect(.EntireRow, .Parent.Columns("B")).FormulaR1C1 = _
                "=""Subtotal: "" & R[-1]C"
        End With
        .Columns("A").Delete
        .Columns("A").RemoveSubtotal
    End With
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

 

[Scarbo]

Thanks Peter.

BorderAround is just what I needed.

Apologies for the all left align - will use the Code Tags in future!

 

[Legacy 185509]

Thanks Peter I was able to use that too, so nicely done.

 

[mdiament]

Hi, I also have a similar situation. I have data in the form of transactions by date. First I sort everything by year, but then I need to insert two blank rows after each year so I can sum the data. Beginning example

01/05/05
01/06/05
03/07/05
10/06/06
11/05/06
02/03/07
05/06/07

After

01/05/05
01/06/05
03/07/05


10/06/06
11/05/06


02/03/07
05/06/07


Any help writing the vba code would be great.

Thanks

 

[Peter_SSs]

Welcome to the MrExcel board!

I've assumed dates in column A starting in row 2, and that you have already sorted your dates.
Try this in a copy of your workbook.

Sub InsertRows()
  Dim lr As Long, r As Long
  
  Application.ScreenUpdating = False
  lr = Range("A" & Rows.Count).End(xlUp).Row
  For r = lr To 3 Step -1
    If Year(Cells(r, 1).Value) <> Year(Cells(r - 1, 1).Value) Then
      Rows(r).Resize(2).Insert
    End If
  Next r
  Application.ScreenUpdating = True
End Sub

 

[mdiament]

Peter,

Thank you for your timely response, the macro works excellently. Is it possible to change from the dates starting in row 2 to being able to run the macro 1 cell below the active cell clicked on? On each workbook we have the dates starting at a different row so running off 1 cell below the active cell we are clicked on would be much easier.

Thank you

 

[Peter_SSs]

I'm not clear whether you would have the active cell on the first date or a heading 1 row above the first date. I've assumed the heading option. If you are on the first date, change the red "2" to "1"

Sub InsertRows()
  Dim lr As Long, r As Long, rw As Long, col As Long
  
  Application.ScreenUpdating = False
  rw = ActiveCell.Row
  col = ActiveCell.Column
  lr = Cells(Rows.Count, col).End(xlUp).Row
  For r = lr To rw + 2 Step -1
    If Year(Cells(r, col).Value) <> Year(Cells(r - 1, col).Value) Then
      Rows(r).Resize(2).Insert
    End If
  Next r
  Application.ScreenUpdating = True
End Sub

 

[mdiament]

Thank you so much! This will save a lot of time.

 

[robertwp7472]

Peter,
i am using your code block not as a stand alone sub but as an inserted WITH and it works great. however, my sheet has an added colorization of the rows and I figured out how to remove the color for the inserted row but it only seems to be affecting the first cell of the row. Here is what I have

'Insert Blank Row when order numer changes
    With Range("A2", 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
        .EntireColumn.Interior.Color = 16777215 'This line turns color to white
    End With

What do I need to change to get it to affect the whole Row or even better if it can merge the cells across the row from (A:I) just for the Row being inserted?