Add frequency proportion column and total
Brief description:
Adds a column of frequency portions next to a column of frequency counts and puts totals in the last row
Full description:
Based on a column of frequencies, this routine adds the portion each cell represents of the total count and inserts the totals in the bottom row.
This is a common output table used in market research and elsewhere.
To use: From the range of cell values containing frequency data output, select the adjacent range and run the macro. The empty cells will be filled with the formula for the portions based on the frequency count.
Note: The range receives some checks but the bottom row is replaced with the totals so make sure the bottom row does not have data.
Future feature: Check the bottom row is empty to avoid data deletion.
Code:
Sub CalculateTableValues()
'Author: Dale Anderson
'Description: Using a selected range of two columns and n number of rows
' with the first row containing frequencies to be summed, this macro totals
' the frequencies at the bottom row, calculates the proportion of frequencies,
' displays them in the second column and shows their total ie 100% in the
' bottom of the second column.
' All values are formated as centered and percentages are shown with
' 1 decimal place, totals are shown in bold
Dim WorkingRange As Range
Dim RowsInArea As Integer, n As Integer
Dim ValuesToBeSummed As Range
Dim RangeString1 As String, RangeString2 As String
Dim RangeString3 As String, RangeString4 As String
Dim SumOfFreq As Range, SumOfPercent As Range
Dim CheckRange As Range
Set WorkingRange = Selection
RowsInArea = WorkingRange.Rows.count
'----------------Error Checking------------------------------------------------
'----------------Check the selected area is the correct size-------------
If WorkingRange.Columns.count <> 2 Or Not WorkingRange.Rows.count > 1 Then
MsgBox "The selected area must contain two columns with the first" & _
" column containing the values to be summed and an empty row " & _
"for the totals" & Chr(10) & Chr(10) & "Please select a different area"
Exit Sub
End If
'------------------------------------------------------------------------
'----------------Check that no text is selected-------------------------
For Each CheckRange In WorkingRange
If IsNumeric(CheckRange) = False Then
MsgBox "The selected area should only contain blank cells" & _
" or cells with numeric values"
Exit Sub
End If
Next CheckRange
'------------------------------------------------------------------------
'-----------------------------------------------------------------------------
'----------------Define ranges to work with---------------------
With WorkingRange
RangeString1 = .Cells(1).Address
RangeString2 = .Cells(RowsInArea - 1, 1).Address
RangeString3 = .Cells(1, 2).Address
RangeString4 = .Cells(RowsInArea - 1, 2).Address
Set SumOfFreq = .Cells(RowsInArea, 1)
Set SumOfPercent = .Cells(RowsInArea, 2)
End With
'----------------------------------------------------------------
'-----------Define summation formulas to total required values -----
SumOfFreq.Formula = _
"=sum(" & RangeString1 & ":" & RangeString2 & ")"
SumOfPercent.Formula = _
"=sum(" & RangeString3 & ":" & RangeString4 & ")"
'------------------------------------------------------------------
'------------Define formulas to calculate percentages--------------
For n = 1 To RowsInArea - 1
With WorkingRange.Cells(n, 2)
.Formula = "=" & .Offset(0, -1).Address & "/" & SumOfFreq.Address
End With
Next n
'-------------------------------------------------------------------
'------------------Format Selected area as required------------------
With WorkingRange
.HorizontalAlignment = xlCenter
.Range(Cells(RowsInArea, 1), Cells(RowsInArea, 2)).Font.Bold = True
.Range(Cells(1, 2), Cells(RowsInArea, 2)).Style = "Percent"
.Range(Cells(1, 2), Cells(RowsInArea - 1, 2)).NumberFormat = _
"0.0" & "%"
End With
'-------------------------------------------------------------------
End Sub