• Status: Solved
• Priority: Medium
• Security: Public
• Views: 1353

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
W.E.B
• 3
• 3
• 2
1 Solution

Commented:
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

Commented:
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 Commented:
Hello,
appreciate the help,

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

thanks
sample2.xlsx
0

Commented:
byundt,

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

Commented:
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

Commented:
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

Commented:
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 Commented:
Thanks a million guys,
works great.
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.