Still celebrating National IT Professionals Day with 3 months of free Premium Membership. Use Code ITDAY17

x
Solved

Posted on 2013-11-06
Medium Priority
1,158 Views
Hello,
I'm using below code to add Summary to columns.
Number of rows and columns are different.

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

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
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
• 3
• 3
• 2

LVL 12

Expert Comment

ID: 39629040
Wass_QA,

``````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
``````
0

LVL 81

Expert Comment

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
``````
0

Author Comment

ID: 39629097
Hello,
appreciate the help,

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

thanks
sample2.xlsx
0

LVL 12

Expert Comment

ID: 39629104
byundt,

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

LVL 81

Expert Comment

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
``````
0

LVL 12

Accepted Solution

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
``````
0

LVL 81

Expert Comment

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.

0

Author Comment

ID: 39629128
Thanks a million guys,
works great.
0

## Featured Post

Question has a verified solution.

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

You need to know the location of the Office templates folder, so that when you create new templates, they are saved to that location, and thus are available for selection when creating new documents.  The steps to find the Templates folder path are â€¦
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 Micro Tutorial demonstrates how to create Excel charts: column, area, line, bar, and scatter charts. Formatting tips are provided as well.