Solved

VBA to add percentage

Posted on 2013-11-06
9
800 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:Wass_QA
  • 3
  • 3
  • 2
9 Comments
 
LVL 12

Expert Comment

by:Harry Lee
Comment Utility
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 80

Expert Comment

by:byundt
Comment Utility
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:Wass_QA
Comment Utility
Hello,
appreciate the help,
please see attached.

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

thanks
sample2.xlsx
0
 
LVL 12

Expert Comment

by:Harry Lee
Comment Utility
byundt,

You can do better than simply change the reference of other people's work.
0
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

 
LVL 80

Expert Comment

by:byundt
Comment Utility
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
Comment Utility
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 80

Expert Comment

by:byundt
Comment Utility
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:Wass_QA
Comment Utility
Thanks a million guys,
works great.
0

Featured Post

6 Surprising Benefits of Threat Intelligence

All sorts of threat intelligence is available on the web. Intelligence you can learn from, and use to anticipate and prepare for future attacks.

Join & Write a Comment

Workbook link problems after copying tabs to a new workbook? David Miller (dlmille) Intro Have you either copied sheets to a new workbook, and after having saved and opened that workbook, you find that there are links back to the original sou…
You can of course define an array to hold data that is of a particular type like an array of Strings to hold customer names or an array of Doubles to hold customer sales, but what do you do if you want to coordinate that data? This article describes…
The viewer will learn how to simulate a series of coin tosses with the rand() function and learn how to make these “tosses” depend on a predetermined probability. Flipping Coins in Excel: Enter =RAND() into cell A2: Recalculate the random variable…
This Micro Tutorial will demonstrate in Google Sheets how to use the HYPERLINK function to create live links inside your spreadsheet.

762 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