asked on

VBA to add percentage

Hello,
Can you please help,
I'm using below code to add Summary to columns.
Can you please help me to add the percentage underneath the summary.
Number of rows and columns are different.

Please see sample attached.

Font Color RED
Percentage sign
formula = Column Summary / Subtotal Amount

'Add Summary To Columns
Sheets("Yearly_Totals").Select
Dim r As Range, j As Long, k As Long
j = Range("A1").End(xlToRight).Column
For k = 5 To j
Set r = Range(Cells(1, k), Cells(1, k).End(xlDown))
r.End(xlDown).Offset(2, 0) = WorksheetFunction.Sum(r)
Next k
With Range("A1").CurrentRegion
With .Offset(.Rows.Count).Resize(2)
.Interior.Color = vbYellow
End With
End With

thanks,
sample.xlsx

Harry Lee

Wass_QA,

I have completely rewrote your macro. Please use the following macro.

Sub AddColumnSummary()

Dim WS As Worksheet, Clmns As Long, Rws As Long, Clmn As Long, Rng As Range

Set WS = Sheets("Yearly_Totals")
Clmns = WS.Cells(1, Columns.Count).End(xlToLeft).Column
Rws = WS.Cells(Rows.Count, 1).End(xlUp).Row

    For Clmn = 5 To Clmns
        Set Rng = WS.Range(Cells(2, Clmn), Cells(Rws, Clmn))
        WS.Cells(Rws + 2, Clmn).Formula = "=Sum(" & Rng.Address & ")"
    Next
        
    For Clmn = 5 To Clmns - 2
        WS.Cells(Rws + 3, Clmn).Formula = "=Average(" & Cells(Rws + 2, Clmn).Address & "/" & Cells(Rws + 2, Clmns - 1).Address & ")"
    Next

With Range(Cells(Rws + 1, 1), Cells(Rws + 2, Clmns))
    .Interior.Color = vbYellow
    .Font.Bold = True
End With
With Range(Cells(Rws + 3, 5), Cells(Rws + 3, Clmns - 2))
    .Font.Color = vbRed
    .Style = "Percent"
    .NumberFormat = "0.00%"
End With

With Cells(Rws + 2, Clmns - 1).Font
    .Size = 15
    .Bold = True
    .Color = vbRed
End With

End Sub

Open in new window

byundt

If worksheet Yearly_Totals is not the active sheet when the HarryHYLee's macro is run, you will get unexpected results. The following tweak to that code will circumvent those problems.

Note: the sample workbook posted in the question does not have a worksheet named "Yearly_Totals". I used worksheet Sheet1 instead in the code below.

Sub AddColumnSummary()

Dim Clmns As Long, Rws As Long, Clmn As Long, Rng As Range

'With Worksheets("Yearly_Totals")
With Worksheets("Sheet1")
    Clmns = .Cells(1, Columns.Count).End(xlToLeft).Column
    Rws = .Cells(Rows.Count, 1).End(xlUp).Row
    
        For Clmn = 5 To Clmns
            Set Rng = .Range(.Cells(2, Clmn), .Cells(Rws, Clmn))
            .Cells(Rws + 2, Clmn).Formula = "=SUM(" & Rng.Address & ")"
        Next
            
        For Clmn = 5 To Clmns - 2
            .Cells(Rws + 3, Clmn).Formula = "=" & .Cells(Rws + 2, Clmn).Address & "/" & .Cells(Rws + 2, Clmns - 1).Address
        Next
    
    With Range(.Cells(Rws + 1, 1), .Cells(Rws + 2, Clmns))
        .Interior.Color = vbYellow
        .Font.Bold = True
    End With
    With Range(.Cells(Rws + 3, 5), .Cells(Rws + 3, Clmns - 2))
        .Font.Color = vbRed
        .Style = "Percent"
        .NumberFormat = "0.00%"
    End With
    
    With .Cells(Rws + 2, Clmns - 1).Font
        .Size = 15
        .Bold = True
        .Color = vbRed
    End With
End With

End Sub

Open in new window

W.E.B

ASKER

Hello,
appreciate the help,
please see attached.

it works on sheet 1
but not on sheet2, sheet3.

thanks
sample2.xlsx

Harry Lee

byundt,

You can do better than simply change the reference of other people's work.

byundt

You will need to clear the cells with error values on Sheet2 and Sheet3. The following macro will then work:

Sub AddColumnSummary()

Dim Clmns As Long, Rws As Long, Clmn As Long
Dim ws As Worksheet
Dim Rng As Range

For Each ws In ActiveWorkbook.Worksheets
    With ws
        Clmns = .Cells(2, Columns.Count).End(xlToLeft).Column
        Rws = .Cells(Rows.Count, 1).End(xlUp).Row
        
            For Clmn = 5 To Clmns
                Set Rng = .Range(.Cells(2, Clmn), .Cells(Rws, Clmn))
                .Cells(Rws + 2, Clmn).Formula = "=SUM(" & Rng.Address & ")"
            Next
                
            For Clmn = 5 To Clmns - 2
                .Cells(Rws + 3, Clmn).Formula = "=" & .Cells(Rws + 2, Clmn).Address & "/" & .Cells(Rws + 2, Clmns - 1).Address
            Next
        
        With Range(.Cells(Rws + 1, 1), .Cells(Rws + 2, Clmns))
            .Interior.Color = vbYellow
            .Font.Bold = True
        End With
        With Range(.Cells(Rws + 3, 5), .Cells(Rws + 3, Clmns - 2))
            .Font.Color = vbRed
            .Style = "Percent"
            .NumberFormat = "0.00%"
        End With
        
        With .Cells(Rws + 2, Clmns - 1).Font
            .Size = 15
            .Bold = True
            .Color = vbRed
        End With
    End With
Next
End Sub

Open in new window

ASKER CERTIFIED SOLUTION

Harry Lee

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

byundt

HarryHYLee,
I gave you full credit for the code at the beginning of my opening Comment.

My contributions in this thread are minor tweaks to that code, made necessary only because the Asker changed the problem. I am sorry that those efforts gave offense.

Brad

W.E.B

ASKER

Thanks a million guys,
works great.