Solved

VBA to add percentage

Posted on 2013-11-06
9
945 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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 3
  • 3
  • 2
9 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
Independent Software Vendors: We Want Your Opinion

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 
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 250 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

Free Tool: IP Lookup

Get more info about an IP address or domain name, such as organization, abuse contacts and geolocation.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

Question has a verified solution.

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

Suggested Solutions

If you need to start windows update installation remotely or as a scheduled task you will find this very helpful.
Access developers frequently have requirements to interact with Excel (import from or output to) in their applications.  You might be able to accomplish this with the TransferSpreadsheet and OutputTo methods, but in this series of articles I will di…
This lesson covers basic error handling code in Microsoft Excel using VBA. This is the first lesson in a 3-part series that uses code to loop through an Excel spreadsheet in VBA and then fix errors, taking advantage of error handling code. This l…
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…

749 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