Go Premium for a chance to win a PS4. Enter to Win

x
?
Solved

VBA to add percentage

Posted on 2013-11-06
9
Medium Priority
?
1,240 Views
Last Modified: 2013-11-06
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
0
Comment
Question by:W.E.B
  • 3
  • 3
  • 2
8 Comments
 
LVL 12

Expert Comment

by:Harry Lee
ID: 39629040
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

0
 
LVL 81

Expert Comment

by:byundt
ID: 39629070
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

0
 

Author Comment

by:W.E.B
ID: 39629097
Hello,
appreciate the help,
please see attached.

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

thanks
sample2.xlsx
0
What does it mean to be "Always On"?

Is your cloud always on? With an Always On cloud you won't have to worry about downtime for maintenance or software application code updates, ensuring that your bottom line isn't affected.

 
LVL 12

Expert Comment

by:Harry Lee
ID: 39629104
byundt,

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

Expert Comment

by:byundt
ID: 39629106
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

0
 
LVL 12

Accepted Solution

by:
Harry Lee earned 1000 total points
ID: 39629111
Wass_QA,

I have changed the way the macro works a little bit.

Instead of hardcoding the sheet name, it's now using Activesheet.

I have also changed the column count to use 2nd row instead of the 1st row.

Since you have a lot of too small columns, I have added Columns.Autofit at the end.

Sub AddColumnSummary()

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

Set WS = ActiveSheet
Clmns = WS.Cells(2, 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
Columns.AutoFit
End Sub

Open in new window

0
 
LVL 81

Expert Comment

by:byundt
ID: 39629117
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
0
 

Author Comment

by:W.E.B
ID: 39629128
Thanks a million guys,
works great.
0

Featured Post

Vote for the Most Valuable Expert

It’s time to recognize experts that go above and beyond with helpful solutions and engagement on site. Choose from the top experts in the Hall of Fame or on the right rail of your favorite topic page. Look for the blue “Nominate” button on their profile to vote.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

This article descibes how to create a connection between Excel and SAP and how to move data from Excel to SAP or the other way around.
After seeing numerous questions for Dynamic Data Validation I notice that most have used Visual Basic to solve the problem. This suggestion is purely formula based and can be used in multiple rows.
This Micro Tutorial demonstrates in Microsoft Excel how to consolidate your marketing data by creating an interactive charts using form controls. This creates cool drop-downs for viewers of your chart to choose from.
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…

877 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