How do I modify a macro to include formatting - need to add an extra row and bold certain text.

Posted on 2014-08-27
Last Modified: 2014-08-28
The attached file has a macro which inserts subtotals on each page.  There are two controls for adding subtotals and removing the subtotals - buttons at the top of the form.
I need assistance in modifying the macros so that when the subtotals are visible, the following formatting takes place.  An additional blank row appears above the subtotals, there are no boarders around the subtotal row and the subtotal row is in "bold."  When the remove subtotal button is selected, the extra row is deleted.  I have attached the document.  As a side note, Glen Ray assisted on 7/22/2014. ID#40210902.
Question by:klitton7
    LVL 27

    Accepted Solution

    Since you needed to change from inserting one total row to two (a blank row & then total row), I modified the two subroutines that deal with inserting and removing total rows:

    Sub Insert_Subtotals()
        Dim r, i, x As Integer
        Range("A9").Select 'must start on row 9 to avoid false subtotal on top
        Do Until ActiveCell.Value = ""
            If (ActiveCell.Row - 6) Mod 28 = 0 Then
                'insert blank row
                ActiveCell.Offset(-1, 0).Select
                Range(ActiveCell, ActiveCell.Offset(0, 14)).Select
                For x = xlEdgeLeft To xlInsideHorizontal '7 to 12
                    If x <> xlEdgeTop Then
                        With Selection.Borders(x)
                            .LineStyle = xlNone
                        End With
                    End If
                Next x
                'insert page Total row
                ActiveCell.Offset(1, 0).Select
                ActiveCell.Value = "Total on this page"
                ActiveCell.Offset(0, 11).FormulaR1C1 = "=SUM(R[-27]C:R[-1]C)"
                ActiveCell.Offset(0, 12).FormulaR1C1 = "=SUM(R[-27]C:R[-1]C)"
                ActiveCell.Offset(0, 14).FormulaR1C1 = "=SUM(R[-27]C:R[-1]C)"
                Range(ActiveCell, ActiveCell.Offset(0, 14)).Select
                Selection.Font.Bold = True
            End If
            ActiveCell.Offset(1, 0).Select
        r = ((ActiveCell.Row - 6) Mod 28)
        'insert blank row
        'insert page Total row
        ActiveCell.Offset(1, 0).Select
        ActiveCell.Value = "Total on this page"
        ActiveCell.Offset(0, 11).FormulaR1C1 = "=SUM(R[-" & r & "]C:R[-2]C)"
        ActiveCell.Offset(0, 12).FormulaR1C1 = "=SUM(R[-" & r & "]C:R[-2]C)"
        ActiveCell.Offset(0, 14).FormulaR1C1 = "=SUM(R[-" & r & "]C:R[-2]C)"
        ActiveCell.RowHeight = 19.5
        i = ActiveCell.Row - 6
        ActiveCell.Offset(1, 0).Value = "GRAND TOTALS"
        ActiveCell.Offset(1, 11).FormulaR1C1 = "=SUM(R[-" & i & "]C:R[-1]C)/2"
        ActiveCell.Offset(1, 12).FormulaR1C1 = "=SUM(R[-" & i & "]C:R[-1]C)/2"
        ActiveCell.Offset(1, 14).FormulaR1C1 = "=SUM(R[-" & i & "]C:R[-1]C)/2"
        ActiveCell.Offset(1, 0).RowHeight = 19.5
        Range(ActiveCell, ActiveCell.Offset(1, 14)).Select
        Selection.Font.Bold = True
        'copy formats for totals
        Range(ActiveCell.Offset(0, 11), ActiveCell.Offset(0, 14)).Copy
        Range(ActiveCell.Offset(0, 11), ActiveCell.Offset(1, 14)).PasteSpecial xlPasteFormats
        Application.CutCopyMode = False
    End Sub

    Open in new window

    The logic assumes that 28 rows will fit on a page, given the current row height of 19.50/row.

    There was also an error in the last page Total row (before Grand Totals); it was looking too far up the column to do the sum.  There was a line of code preparing for that (r= (ActiveCell.Row - 6) Mod 28) but it wasn't used.  I updated that also.

    Sub Remove_Subtotals()
        Dim rng As Range
        Dim cl As Object
        Set rng = Range("A7:A" & Cells.SpecialCells(xlLastCell).Row)
        For Each cl In rng
            If cl.Text = "" Then 'remove blank row and total row after
                cl.Offset(1, 0).EntireRow.Delete
            End If
        Next cl
        If ActiveCell.Value = "GRAND TOTALS" Then ActiveCell.EntireRow.Delete
    End Sub

    Open in new window

    This is actually simplified from its previous version.

    I added some addtional lines to test (copied and pasted existing data to the bottom) and it looks correct.  But, let me know if you have any issues.


    Author Comment

    Glenn - yes, this is exactly what I was looking for and thanks for updating code to correct error in previous version.

    Write Comment

    Please enter a first name

    Please enter a last name

    We will never share this with anyone.

    Featured Post

    How to run any project with ease

    Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
    - Combine task lists, docs, spreadsheets, and chat in one
    - View and edit from mobile/offline
    - Cut down on emails

    Drop Down List with Unique/Distinct Values (enhancing the Combo-Box with a few steps and a little code) David miller (dlmille) Intro Have you ever created a data validation list from a database field or spreadsheet column (e.g., Zip Codes or Co…
    Introduction This Article briefly covers methods of calculating the NPV and IRR variants in Excel as well as the limitations in calculating and interpreting IRR results. Paraphrasing Richard Shockley, author of my favourite finance reference tex…
    The viewer will learn how to simulate a series of sales calls dependent on a single skill level and learn how to simulate a series of sales calls dependent on two skill levels. Simulating Independent Sales Calls: Enter .75 into cell C2 – “skill leve…
    Excel styles will make formatting consistent and let you apply and change formatting faster. In this tutorial, you'll learn how to use Excel's built-in styles, how to modify styles, and how to create your own. You'll also learn how to use your custo…

    759 members asked questions and received personalized solutions in the past 7 days.

    Join the community of 500,000 technology professionals and ask your questions.

    Join & Ask a Question

    Need Help in Real-Time?

    Connect with top rated Experts

    8 Experts available now in Live!

    Get 1:1 Help Now