Make sub to format and total ranges

NVIT
NVIT used Ask the Experts™
on
Before.xlsx shows the current state.
After.xlsx shows what I want.

In Before, for User 1, I recorded the macro to make it look like After.

Is there a way to make this more 'generic' so that it runs for the other Users, regardless of how many?

Sub Title_And_Total_Group()
    Range("A4").Select
    Selection.Copy
    Range("C3").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Selection.Font.Bold = True
    With Selection.Font
        .Name = "Calibri"
        .Size = 14
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    Range("F8").Select
    ActiveCell.FormulaR1C1 = "=SUM(R[-4]C:R[-1]C)"
    Range("F8").Select
    Selection.Copy
    Range("F8:M8").Select
    ActiveSheet.Paste
    Selection.Font.Bold = True
    Selection.End(xlToLeft).Select
    Range("A11").Select
End Sub

Open in new window

Before.xlsx
After.xlsx
Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
View Solutions Only
aikimark
Top Expert 2014

Commented:
.xlsx can not contain VBA code.  You will need to save as .xlsm format
NVITEnd-user support

Author

Commented:
I know that. Can you help w/ a macro solution?
aikimark
Top Expert 2014

Commented:
Ah.  I'll look at it tomorrow AM.
Excel & VBA Expert
Most Valuable Expert 2018
Awarded 2015
Commented:
Please try this.....
Sub ApplyFormatAndFormuals()
Dim rng As Range
Application.ScreenUpdating = False
For Each rng In Range("A:A").SpecialCells(xlCellTypeConstants, 2).Areas
    If rng.Cells(1).Row <> 1 Then
        rng.Cells(1).Copy rng.Cells(1).Offset(-1, 2)
        With rng.Cells(1).Offset(-1, 2).Font
            .Bold = True
            .Size = 14
            .Name = "Calibri"
        End With
        rng.Cells(rng.Rows.Count + 1).Offset(0, 5).Resize(, 8).FormulaR1C1 = "=SUM(R[-4]C:R[-1]C)"
        rng.Cells(rng.Rows.Count + 1).Offset(0, 5).Resize(, 8).Font.Bold = True
    End If
Next rng
Application.ScreenUpdating = True
End Sub

Open in new window

Rgonzo1971
Top Expert 2016
Commented:
HI,

Since the number of lines is variable, then try
Sub ApplyFormatAndFormuals()
Dim rng As Range
Application.ScreenUpdating = False
For Each rng In Range("A:A").SpecialCells(xlCellTypeConstants, 2).Areas
    If rng.Cells(1).Row <> 1 Then
        rng.Cells(1).Copy rng.Cells(1).Offset(-1, 2)
        With rng.Cells(1).Offset(-1, 2).Font
            .Bold = True
            .Size = 14
            .Name = "Calibri"
        End With
        rng.Cells(rng.Rows.Count + 1).Offset(0, 5).Resize(, 8).FormulaR1C1 = "=SUM(R[-" & rng.Rows.Count & "]C:R[-1]C)"
        rng.Cells(rng.Rows.Count + 1).Offset(0, 5).Resize(, 8).Font.Bold = True
    End If
Next rng
Application.ScreenUpdating = True
End Sub

Open in new window

Regards
Subodh Tiwari (Neeraj)Excel & VBA Expert
Most Valuable Expert 2018
Awarded 2015

Commented:
Good point Rgonzo. I missed that.
Thanks for tweaking the code accordingly. :)
Rob HensonFinance Analyst

Commented:
You can get a similar result without VBA and using the Subtotal Wizard or with a slight change to the data format, you could use a Pivot Table.

Thanks
Rob H
Before.xlsx
NVITEnd-user support

Author

Commented:
Thank you, Neeraj and Rgonzo!
NVITEnd-user support

Author

Commented:
Is it easy enough for you to revise your code and add bottom borders on the last 2 rows as shown?
Add bottom borders under 2 total rows
Or, should I open another question?

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial