Insert Blank Rows when Column Value Changes

Question

Good Day All

I am looking for some assistance please. I am looking for a macro.

I would like to insert two blank rows when the value in column B changes. In the first inserted row, the macro must calculate a subtotal of the rows above in column F, G, H, I & J. In the second inserted row it must total the subtotal above.

I have uploaded a sample of my expected outcome:- the font in italics and bold reflect the information which the macro should provide.

My document has around 15000 unique entries in column B so if possible a macro that will accomodate this.

Regards

Derryn

Answer 1

When I run it, the first worksheet runs fine  however when it starts on the second it pops up an error (Run-time error '1004': Method 'Union' of object'_Global' failed) and points the debugger to the following line: 

      Set All = Union(All, R)

The reason is that you can not unite cells in different sheets... which happens in the second loop... because:

When a sub is called, every local variable is "set to zero", that means object variables are set to "Nothing". The variable All isn't reset and contains the cells from the first loop.

So you have 2 ways to go:

a) Add the line

  Set All = Nothing

after

  Wsh.Select

b) Create a main sub and call Sub Test as I've posted.

Sub Main()

  Dim Wsh As Worksheet

  For Each Wsh In Worksheets

    Wsh.Select

    Test

  Next

End Sub

Andreas.

EDIT: I've made a fault, change the line

  C.Formula = "=SUM(" & Intersect(C.EntireColumn, All.EntireRow).Address & ")"

to

    C.Formula = "=SUM(" & Intersect(C.EntireColumn, All.EntireRow, _

      Range("F1:J" & R.Row - 1)).Address & ")"

to prevent the circular reference.

And please remove my stupid "R.Select", sorry for the inconvenience.

Answer 2

Your picture shows that we can create the subtotals with Excels internal function, grouped by column B. So I suggest to go a different way.

The result is the same as the macro from OssieMac, except that I create formulas, he creates the values directly.

Also for my macro applies: The process can not be undone! For this, you would have to write another macro.

Andreas.

Sub Test()

  Dim R As Range, C As Range

  Dim i As Long

  'This speed up some things

  Application.ScreenUpdating = False

  Application.Calculation = xlCalculationManual

  Application.EnableEvents = False

  'Insert the individual subtotals

  'Group by column B, subtotals in F:J

  Range("A1").CurrentRegion.Subtotal GroupBy:=2, Function:=xlSum, _

    TotalList:=Array(6, 7, 8, 9, 10), _

    Replace:=True, PageBreaks:=False, SummaryBelowData:=True

  'Find each subtotal formula

  Set R = Columns("F").Find("=SUBTOTAL", _

    LookIn:=xlFormulas, LookAt:=xlPart)

  'Remember the last row

  i = R.Row

  Do

    'Format the "Subtotal" row

    With R.EntireRow.Font

      .Bold = True

      .Italic = True

    End With

    With Intersect(Range("A:E"), R.EntireRow)

      .Merge

      .HorizontalAlignment = xlRight

    End With

    'Insert a row below

    R.Offset(1).EntireRow.Insert

    Set C = R.Offset(1)

    'Format the "Total" row

    With C.EntireRow.Font

      .Bold = True

      .Italic = True

    End With

    With Intersect(Range("A:E"), C.EntireRow)

      .Cells(1, 1).Formula = "Total " & Range("B" & R.Row - 1)

      .Merge

      .HorizontalAlignment = xlRight

    End With

    'Create the sum of the subtotals

    With Intersect(Range("F:J"), C.EntireRow)

      .Cells(1, 1).Formula = Replace("=SUM(X)", "X", .Offset(-1).Address)

      .Merge

      .HorizontalAlignment = xlCenter

    End With

    'Find next subtotal

    Set R = Columns("F").FindNext(R)

  Loop Until R.Row = i

  Application.ScreenUpdating = True

  Application.Calculation = xlCalculationAutomatic

  Application.EnableEvents = True

End Sub

Answer 3

Hello Derryn,

I am assuming that the picture you posted is what you want to finish up with and that currently the data looks like the following. (I didn't insert values in columns C, D and E because not relevant for how I interpret your question.)

If my assumption is not correct then my solution will not be correct.

I am assuming that you know how to install the macro.

Ensure you backup your workbook before running the code in case it does not do what you expect.

Note my comments near the start of the code where you might need to edit the code to your worksheet name and also the row number where the actual data starts. Currently I have assumed you have column headers in row 1 and actual data starts at row 2.  If you are using more than one row for column headers then edit the row number to the row where the actual data starts.

Sub SubTotalData()

    Dim ws As Worksheet

    Dim lngFirstDataRow As Long

    Dim lngLastRow As Long

    Dim r As Long

    Dim rngColB As Range

    Dim rngCel As Range

    Dim lngFirst As Long

    Dim lngLast As Long

    '***************************************************************

    'Edit "Sheet1" in following line to your worksheet name

    Set ws = Worksheets("Sheet1")

    'Edit 2 in following line to the first row number of actual data

    lngFirstDataRow = 2

    '***************************************************************

    lngLastRow = LastRowOrCol(ws, True)

    With ws

        For r = lngLastRow To lngFirstDataRow Step -1

            If r <> lngFirstDataRow Then

                If .Cells(r, "B").Value <> .Cells(r - 1, "B") Then

                    .Rows(r & ":" & r + 1).Insert Shift:=xlDown

                End If

            End If

        Next r

        lngLastRow = LastRowOrCol(ws, True) + 2

        For r = lngFirstDataRow To lngLastRow

            If r = lngFirstDataRow Then

                lngFirst = r    'First row for Sum function

            Else

                If .Cells(r, "B") = "" Then 'Empty cell

                    lngLast = r - 1     'Last row for Sum function

                End If

            End If

            If lngFirst > 0 And lngLast > 0 Then

                .Cells(r, "F") = WorksheetFunction.Sum(.Range(.Cells(lngFirst, "F"), _

                                    .Cells(lngLast, "F")))

                .Cells(r, "G") = WorksheetFunction.Sum(.Range(.Cells(lngFirst, "G"), _

                                    .Cells(lngLast, "G")))

                .Cells(r, "H") = WorksheetFunction.Sum(.Range(.Cells(lngFirst, "H"), _

                                    .Cells(lngLast, "H")))

                .Cells(r, "I") = WorksheetFunction.Sum(.Range(.Cells(lngFirst, "I"), _

                                    .Cells(lngLast, "I")))

                .Cells(r, "J") = WorksheetFunction.Sum(.Range(.Cells(lngFirst, "J"), _

                                    .Cells(lngLast, "J")))

                .Cells(r, "E") = "SUBTOTAL"

                .Range(.Cells(r, "E"), Cells(r, "J")).Font.Italic = True

                .Range(.Cells(r, "E"), Cells(r, "J")).Font.Bold = True

                .Range(.Cells(r, "E"), Cells(r, "J")).NumberFormat = "#,##0.00"

                .Cells(r, "E").HorizontalAlignment = xlRight

                r = r + 1       'Increment row number for total of subtotals

                With .Range(.Cells(r, "F"), .Cells(r, "J"))     'Merge and centre cells

                    .HorizontalAlignment = xlCenter

                    .VerticalAlignment = xlBottom

                    .WrapText = False

                    .Orientation = 0

                    .AddIndent = False

                    .IndentLevel = 0

                    .ShrinkToFit = False

                    .ReadingOrder = xlContext

                    .MergeCells = True

                End With

                .Cells(r, "F") = WorksheetFunction.Sum(.Range(.Cells(r - 1, "F"), _

                                    .Cells(r - 1, "J")))

                .Cells(r, "E") = "TOTAL " & .Cells(r - 2, "B")

                .Cells(r, "E").HorizontalAlignment = xlRight

                .Range(.Cells(r, "E"), .Cells(r, "F")).Font.Italic = True

                .Range(.Cells(r, "E"), .Cells(r, "F")).Font.Bold = True

                .Range(.Cells(r, "E"), .Cells(r, "F")).NumberFormat = "#,##0.00"

                r = r + 1       'Increment row number to start next group

                lngFirst = r    'Set first row for Sum Function

                lngLast = 0

            End If

        Next r

    End With

End Sub

Function LastRowOrCol(ws As Worksheet, bolRowCol As Boolean, Optional rng As Range) As Long

    'Finds the last used row or column in a worksheet

    'First parameter is Worksheet

    'Second parameter is True for Last Row or False for last Column

    'Third parameter is optional. Use to find the last row or column in a specific range

    Dim lngRowCol As Long

    Dim rngToFind As Range

    If rng Is Nothing Then

        Set rng = ws.Cells

    End If

    If bolRowCol Then

        lngRowCol = xlByRows

    Else

        lngRowCol = xlByColumns

    End If

    With ws

        Set rngToFind = rng.Find(What:="*", _

                LookIn:=xlFormulas, _

                LookAt:=xlPart, _

                SearchOrder:=lngRowCol, _

                SearchDirection:=xlPrevious, _

                MatchCase:=False)

    End With

    If Not rngToFind Is Nothing Then

        If bolRowCol Then

            LastRowOrCol = rngToFind.Row

        Else

            LastRowOrCol = rngToFind.Column

        End If

    End If

End Function

Answer 4

Hi Andreas

Thank you for the prompt reply.

I have amended the formula to suit my required output and wrapped it in a loop to run on all the worksheets in my workbook.

Sub Test()

  Dim R As Range, C As Range

  Dim i As Long

  Dim All As Range

  Dim Wsh As Worksheet

  For Each Wsh In Worksheets

    Wsh.Select

  Application.ScreenUpdating = False

  Application.Calculation = xlCalculationManual

  Application.EnableEvents = False

  Range("A2").CurrentRegion.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(6, 7, 8, 9, 10), _

    Replace:=True, PageBreaks:=False, SummaryBelowData:=True

  Set R = Columns("F").Find("=SUBTOTAL", LookIn:=xlFormulas, LookAt:=xlPart)

  Range("B:B").Select

  Selection.Replace What:="Total", Replacement:=": Total Per Ageing", LookAt:=xlPart, SearchOrder:=xlByRows

  Range("A2").Select

  i = R.Row

  Do

    With R.EntireRow.Font

      .Bold = True

      .Italic = True

    End With

    With Intersect(Range("A:E"), R.EntireRow)

      .Merge

      .HorizontalAlignment = xlRight

    End With

    If All Is Nothing Then

      Set All = R

    Else

      Set All = Union(All, R)

    End If

    R.Offset(1).EntireRow.Insert

    Set C = R.Offset(1)

    With C.EntireRow.Font

      .Bold = True

      .Italic = True

    End With

    With Intersect(Range("A:E"), C.EntireRow)

      .Cells(1, 1).Formula = "GRAND TOTAL " & Range("B" & R.Row - 1)

      .Merge

      .HorizontalAlignment = xlRight

    End With

    With Intersect(Range("F:J"), C.EntireRow)

      .Cells(1, 1).Formula = Replace("=SUM(X)", "X", .Offset(-1).Address)

      .Merge

      .HorizontalAlignment = xlCenter

    End With

    Set R = Columns("F").FindNext(R)

  Loop Until R.Row = i

  Set R = Columns("F").Find("=SUBTOTAL", _

    LookIn:=xlFormulas, LookAt:=xlPart, SearchDirection:=xlPrevious)

  R.Select

  For Each C In Intersect(Range("F:J"), R.EntireRow)

    C.Formula = "=SUM(" & Intersect(C.EntireColumn, All.EntireRow).Address & ")"

  Next

  Application.ScreenUpdating = True

  Application.Calculation = xlCalculationAutomatic

  Application.EnableEvents = True

Next Wsh

End Sub

When I run it, the first worksheet runs fine  however when it starts on the second it pops up an error (Run-time error '1004': Method 'Union' of object'_Global' failed) and points the debugger to the following line: 

      Set All = Union(All, R)

Please help. I'm sorry to be bugging you

Regards

Derryn