# Output the rounded sum of each column in selection

I've written something (i.e. frankensteined from stack exchange) that appears to work but I haven't done much testing on the edge cases. Signed up here for some feedback on what optimizations or other functions/methods I could have used, and whether or not I've missed something critical -- this is my first time dealing with arrays extensively. To be honest the data sizes used will be less than 10000 cells so I doubt the speed will improve much, but I feel like I'm accessing the same data multiple times and would like to learn to reduce redundancy.

Basically I select multiple cells on a worksheet, usually a filtered one, and I want to see how much the sum of each column, rounded as displayed/printed, would vary from the true, precise sum (as excel would show if using the SUM() function). I'll hit the keyboard shortcut and have a Msgbox pop up.

Private DecPlace As Integer 'decimal places for rounding checker vertical
Private boo1 As Boolean 'check if decimal place has been assigned
Sub RoundingMsgbox()
'   Ctrl + E
Dim DataRange as Variant 'values from selection
Dim ResultArr() As String 'output
Dim RoundedSum As Double 'rounded sum
Dim PrecSum As Double 'precise sum
Dim x%, y%, z%, ans%, rng As Range '% = integers
Dim rowslist As New Collection
Dim colslist As New Collection
Dim Lrow As Integer, Lcol As Integer, Xrow As Integer, Xcol As Integer, Tcol() As Integer, Trow() As Integer
On Error GoTo ender
RoundedSum = 0
PrecSum = 0
Selection.SpecialCells(xlCellTypeVisible).Select 'this will split areas??

If boo1 = 0 Then
DecPlace = InputBox("Input rounding decimal places:", , 2)
boo1 = 1
End If
If Selection.Cells.Count < 2 Then Exit Sub
If Selection.Areas.Count = 1 Then 'if contiguous, no need to manually populate an array but did it anyway
DataRange = Selection.Value
Xrow = Selection.Rows.Count
Xcol = Selection.Columns.Count 'Max
ReDim ResultArr(0 To Xcol)
For y = 1 To Selection.Columns.Count
For x = 1 To Selection.Rows.Count
DataRange(x, y) = Selection.Cells(x, y).Value
Next
Next
Else 'non contiguous, find unique rows and cols to prep arrays
For z = 1 To Selection.Areas.Count
For Each rng In Selection.Areas(z).Rows 'L-R, U-D order.
On Error Resume Next
On Error GoTo 0
Next rng
For Each rng In Selection.Areas(z).Columns
On Error Resume Next
On Error GoTo 0
Next rng
Next
Xrow = rowslist.Count
Xcol = colslist.Count
On Error GoTo ender
ReDim Trow(1 To rowslist(rowslist.Count)) 'primitive way of storing the corresponding index of each cell's addresses instead of row/col number
ReDim Tcol(1 To colslist(colslist.Count))
For z = 1 To rowslist.Count
Trow(rowslist(z)) = z
'Debug.Print "row" & rowslist(z)
Next
For z = 1 To colslist.Count
Tcol(colslist(z)) = z
'Debug.Print "col" & colslist(z)
Next
ReDim DataRange(Xrow, Xcol) 'redim after finding max cols
ReDim ResultArr(0 To Xcol)

For z = 1 To Selection.Areas.Count 'populating DataRange array with values ordered by their columns
For Each rng In Selection.Areas(z)
DataRange(Trow(rng.Row), Tcol(rng.Column)) = rng.Value
Next
Next

End If

ResultArr(0) = "Round to " & DecPlace & " decimal places:" & vbCrLf & "Rounded diff ;  Rounded total"
For Lcol = 1 To Xcol
For Lrow = 1 To Xrow
RoundedSum = RoundedSum + WorksheetFunction.Round(CDec(DataRange(Lrow, Lcol)), DecPlace) 'vba round uses banker's rounding so call excel round instead
PrecSum = PrecSum + DataRange(Lrow, Lcol) 'index(arr,0,col) does not work for manually populated array variant
Next Lrow
ResultArr(Lcol) = "Col " & Lcol & vbTab & FormatNumber(RoundedSum - PrecSum, DecPlace, , vbFalse, vbTrue) & vbTab & FormatNumber(RoundedSum, DecPlace, , vbFalse, vbTrue)
RoundedSum = 0
PrecSum = 0
Next Lcol
ans = MsgBox(Join(ResultArr, vbCrLf) & vbCrLf & vbCrLf & "Set new decimal place?", vbYesNo + vbDefaultButton2)
If ans = 6 Then '6 = yes
DecPlace = InputBox("Input rounding decimal places:", , 2)
End If
Exit Sub
ender:
boo1 = 0
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub


For now I'm the only one using it, so I can manually constrain my selections and inputs to either not crash the code or just click "End" if it throws an error. It seems to work fine for "normal" columns but I suspect something hidden in the flawed logic will collapse if this encounters a more intricate spreadsheet. After I figure everything out here eventually I want to expand to horizontal sums, and also reading the selection for "sum", "sumif", "+" etc., and checking the corresponding cells... but that's for later.

I would appreciate any feedback, for both code and comments! Thanks :]

• Welcome to Code Review!
– Mast
Commented Sep 7, 2020 at 8:10
• Please do not update the code in your question to incorporate feedback from answers, doing so goes against the Question + Answer style of Code Review. This is not a forum where you should keep the most updated version in your question. Please see what you may and may not do after receiving answers. Feel free to post a follow-up question instead.
– Mast
Commented Sep 16, 2020 at 9:39
• @Mast sorry about that, I just wanted to edit the comments so it's easier to follow. have you reversed that for me already? If so, thanks! Commented Sep 16, 2020 at 9:44
• Yes, I have reversed this. I understand the sentiment, but do you realize what happens if you keep changing the code and 3 answers on 3 different revisions come in? Whoever comes in later and notices your post, will have trouble understanding what's going on. Good chance 1-2 of those 3 answers no longer make sense.
– Mast
Commented Sep 16, 2020 at 9:47
• Yes I see, I have done no changes to the code itself, just comments, spacing/line breaks, and commented out the error handling which was not intended. But thanks again, understand now that it was improper. And sorry again! Commented Sep 16, 2020 at 9:50

## General Notes

When I tried to run your code as written, it errored out, and did not properly store the precision variable that you had assigned. In general, I recommend avoiding the On Error Goto Ender approach to error handling, as it makes it more difficult to know at a glance if a given behavior is intended. That is, unless you are going to make an error handling section that actually notifies the user, writes to the debug console, or to some log, it is probably best to not have an error handling block, so that when you encounter an error, you know it.

Your code is a bit cluttered, and therefore a bit hard to read. Consider adding spacing between logical steps in your code, along with comments ahead of those steps to explain what they do. An example may look something like

'' Iterate over rows, then columns in selection
For row = 1 to Selection.Rows.Count
For col = 1 to Selection.Columns.Count
'' Do some thing with individual cell in selection
Call DoTheThing(Selection.Item(row,col))
Next col, row


## Modification to Approach

Rather than making collection objects with cell addresses, we can instead find the footprint of all of the areas that the visible cells in the selection take up, and iter over the columns (or rows) that make up that footprint. We can then check if the intsection of that range and the visible portion of the selection is nothing to know whether we should consider that cell for analysis

## Step 0: Initialize Module-Level Variables

There are generally two approaches for handling module level variables of the form

Private mPrecision      As Byte


for this kind of project. If the module level variable is an Object, instead of some primative, is used in many different methods, or there are many objects that need to be initialized, then it is generally best to have some Initialize method, which is called at the beginning of each sub in the module. This might look something like

Private mDict as Scripting.Dictionary, _
mData as Long()

Private Sub Initialize()
'' if objects are initialized, then exit the routine
If Not mDict Is Nothing Then Exit Sub

Set mDict = New Scripting.Dictionary
Redim Long(0 to 100, 0 to 100)
End Sub


however, in this case, we only have one variable that really needs to be tracked, one method using it, and it is a primitive type, so we can handle its initialization using a bool inside of the main method. This will look something like

Private mInitialized as Boolean
Private mPrecision   as Byte

Public Sub MacroExample()

'' check if the precision is assigned
If Not mInitialized Then

'' add entry point for assigning precision at the end of the method
AssignPrec:

'' assign the precision
Let mPrec = SomeFunction()

'' check if assiging the precision for first time, if not exit
If mInitialized Then Exit Sub Else Let mInitialized = True
End If

'' other logic
Call SomeOtherFunctions()

'' query if user wants to assign new precision
If vbYes = MsgBox("Would you like to assign new precision", vbYesNo) Then Goto AssignPrec

End Sub


## Step 1: Find the footprint

This section of code is from one of my previous code review responses, and is a rather quick way to find the total footprint of all of the areas in a given Excel.Range object. Of note, as any single range object can only exist on a single Excel.Worksheet object, we do not need any logic to ensure that this is the case, however, if you have an array of ranges, you would need to check that they all exist on the same worksheet.

'' Function that takes in a Range object, and returns the rectangular footprint of that range, as a range
Public Function footprint(ByRef rng As Excel.Range) As Excel.Range

Dim numAreas           As Long, _
rMin As Long, rMax As Long, _
cMin As Long, cMax As Long, _
iter As Long

'' handle trivial case (numAreas = 1)
Let numAreas = rng.Areas.Count
If numAreas = 1 Then Set footprint = rng: Exit Function

'' Initialize row and column min and maxs
Let rMin = rng.Areas(1).Item(1).Row
Let cMin = rng.Areas(1).Item(1).Column
Let rMax = rng.Areas(1).Item(rng.Areas(1).Count).Row
Let cMax = rng.Areas(1).Item(rng.Areas(1).Count).Column

'' iter over areas, adjusting mins and maxs as needed
For iter = 2 To numAreas
With rng.Areas(iter)
If .Item(1).Row < rMin Then Let rMin = .Item(1).Row
If .Item(1).Column < cMin Then Let cMin = .Item(1).Column
If .Item(.Count).Row > rMax Then Let rMax = .Item(.Count).Row
If .Item(.Count).Column > cMax Then Let cMax = .Item(.Count).Column
End With
Next iter

'' output the footprint
With rng.Worksheet
Set footprint = .Range(.Cells(rMin, cMin), .Cells(rMax, cMax))
End With
End Function


## Step 2: Iter over Columns (or Rows) of the Footprint

Using the Footprint() function defined above, and the Intersect(rngA, rngB) function we can iterate over all of the visible cells in the selection. You expressed interest in modifying your function to iterate over rows instead of columns in your prompt, so I have included an implementation of this in addition to a method for iterating over column by column below.

Sub MacroIterOverSelection()

Dim rng as Excel.Range
Set rng = IIf(Selection.Cells.Count = 1, Selection, Selection.SpecialCells(xlCellTypeVisible))

'' example to iter over all the visible cells in selection, top left to bottom right
Dim cell as Excel.Range
For Each cell in Intersect(Footprint(rng), rng)

'' do analysis

Next cell

'' example to iter over all the cols in the selection, col by col
Dim col as Excel.Range
For Each col in rng.Columns
set col = Intersect(col, rng)

'' Intersect can return nothing so check if that is the case
If Not col Is Nothing Then

'' do analysis

End If
Next col

'' example to iter over all the rows in the selection, row by row
Dim row as Excel.Range
For Each row in rng.Rows
set row = Intersect(row, rng)

'' Intersect can return nothing so check if that is the case
If Not row Is Nothing Then

'' do analysis

End If
next row

End Sub


## Step 3: Gather the relevant Sums

To get the precise sum of a range, in the form that we are iterating over, we can use the WorksheetFunction.Sum function. In the example iterating over column by column, this looks like

let pSum = Excel.WorksheetFunction.Sum(col)


and we can use the Evaluate function to get the rounded sum. This rounded sum calculation looks like

Let rsum = Evaluate("=Sum(Round(" & col.Address & "," & mPrecision & "))")


where mPrecision is the number of decimal places to show. In this rounded case, Excel is calculating an array of rounded values, then summing them, all in one step, and is equivalant to an Excel function of the form

=Sum(Round(A1:A30,3))


where A1:A30 is analagous to the selected range, and 3 to the desired precision.

Adding in logic to trace precedents is more complicated. If you want to only follow the SUM-type precedents, that would look something like

...

''  get visible cells from the selection, and its footprint
Set rng = IIf(Selection.Cells.Count = 1, Selection, Selection.SpecialCells(xlCellTypeVisible))
Set frng = footprint(rng)

Dim RegExp      As New VBScript_RegExp_55.RegExp, _
matches     As VBScript_RegExp_55.match, _
cell        As Excel.Range, _
out         As Excel.Range, _
match       As Variant, _
submatch    As Variant, _
found       As Boolean

Let RegExp.IgnoreCase = True
Let RegExp.Global = True
Let RegExp.MultiLine = True
Let RegExp.Pattern = "(?:SUM$$(.+)$$)?(?:SUMIFS?$$(?:(.+),.+)$$)?"

For Each col In frng.Columns                  '' iter over columns in footprint
Set col = Intersect(col, rng)             '' get overlapping section of column & visible selection

'' if the column has anything in it
If Not col Is Nothing Then
'' iter over each cell with a formula in the column
For Each cell In col
'' iter over the regex output
For Each match In RegExp.Execute(cell.Formula)
'' if no output, skip
If Not match Is Nothing Then
'' iter over ranges encapsulated by sum or sumif(s)
For Each submatch In match.SubMatches
'' if empty, skip
If Not IsEmpty(submatch) Then
'' set flag that says the cell was found to contain a formula
Let found = True

'' union out with the precedents in the cell
Set cell = cell.Worksheet.Range(submatch)
End If
Next submatch
End If
Next match
'' if the cell does not contain a formula, union it with out
If out Is Nothing Then Set out = cell Else Set out = Union(out, cell)
Next cell

'' out is now a range covering the initial selection, plus the precedants of areas w/ a sum statement, minus those cells

'' do logic onto out

End If
Next col
...


## All together

If we throw together all of the relevant bits, we end up with a module which looks something like the below.

There is certainly more to be said for this, in particular about the string building technique, but that may not be relevant to what you are looking for. If it is relevant, and you want more info on it, just let me know, and I explain it

Option Explicit

Private mInitialized    As Boolean
Private mPrecision      As Byte

Public Sub MacroSumVisibleSelectedByCol()

Dim inVal       As String, _
length      As Byte, _
i           As Long, _
rng         As Excel.Range, _
frng        As Excel.Range, _
col         As Excel.Range, _
psum        As Double, _
rsum        As Double

'' On First Run, take input
If Not mInitialized Then
TakeInput:
''  Take user input for number of decimal places
Let inVal = Application.InputBox( _
Title:="Macro In - Sum Selected Visible Cells by Column", _
Prompt:="Input rounding decimal places (0 to 22):", _
Default:=mPrecision, _
Type:=1)                                    '' 1 specifies input is to be a number
If inVal = "False" Then Exit Sub                '' user cancelled

If Not Int(inVal) = inVal Or inVal < 0 Or inVal > 23 Then
If Not vbYes = VBA.MsgBox( _
Title:="Error - Invalid mprecision", _
Prompt:="Number of decimal places must be an integer, n, such that 0 <= n <= 22" & _
vbCrLf & vbCrLf & "Would you like to retry?", _
Buttons:=vbRetryCancel + vbQuestion) _
Then Exit Sub Else GoTo TakeInput           '' exit if user cancelled else go back to input
Else
Let mPrecision = inVal                      '' user gave good input, convert to byte
'Let length = 8 + 2 * mPrecision             '' define line length
End If

'' if redirected into this block from below, ask if
''    useer wants to run again or exit at this point
If Not mInitialized Then
Let mInitialized = True
ElseIf Not vbYes = VBA.MsgBox( _
Title:="Macro Out - Sum Selected Visible Cells by Column", _
Prompt:="Would you like to run macro again?", _
Buttons:=vbYesNo + vbDefaultButton1) Then GoTo CleanExit
End If
End If

''  get visible cells from the selection, and its footprint
Set rng = IIf(Selection.Cells.Count = 1, Selection, Selection.SpecialCells(xlCellTypeVisible))
Set frng = footprint(rng)

''  define string array to hold output lines
''    ( using line format  XFD | 0.### )
ReDim lines(1 To frng.Columns.Count) As String

''  calculate the average, and build strings for ouput
Let i = 0
For Each col In frng.Columns                  '' iter over columns in footprint
Set col = Intersect(col, rng)             '' get overlapping section of column & visible selection
If Not col Is Nothing Then                '' if exists, then
Let i = i + 1                         '' count

'' calc both values
Let psum = Excel.WorksheetFunction.Sum(col)
Let rsum = Evaluate("=Sum(Round(" & col.Address & "," & mPrecision & "))")

'' construct the line
Let lines(i) = join(Array( _
Split(col.Address(ColumnAbsolute:=False), "$")(0), _ Round(psum, mPrecision), _ Round(rsum, mPrecision), _ FormatNumber(rsum - psum, mPrecision, groupdigits:=vbFalse) _ ), vbTab) End If Next col '' trim off unused indices from lines array ReDim Preserve lines(1 To i) '' output to the user If vbYes = VBA.MsgBox( _ Title:="Macro Out - Sum Selected Visible Cells by Column", _ Prompt:="The following sums were calculated:" & vbCrLf & vbCrLf & _ "Column" & vbTab & "Actual" & Space$(mPrecision) & vbTab & "Round" & Space\$(mPrecision) & vbTab & "Diff" & vbCrLf & _
VBA.join(lines, vbCrLf) & vbCrLf & vbCrLf & _
"Would you like to set a default number of decimal places?", _
Buttons:=vbYesNo + vbDefaultButton2) Then GoTo TakeInput

CleanExit:
Exit Sub
End Sub

'' Function that takes in a Range object, and returns the rectangular footprint of that range, as a range
Public Function footprint(ByRef rng As Excel.Range) As Excel.Range

Dim numAreas           As Long, _
rMin As Long, rMax As Long, _
cMin As Long, cMax As Long, _
iter As Long

'' handle trivial case (numAreas = 1)
Let numAreas = rng.Areas.Count
If numAreas = 1 Then Set footprint = rng: Exit Function

'' Initialize row and column min and maxs
Let rMin = rng.Areas(1).Item(1).Row
Let cMin = rng.Areas(1).Item(1).Column
Let rMax = rng.Areas(1).Item(rng.Areas(1).Count).Row
Let cMax = rng.Areas(1).Item(rng.Areas(1).Count).Column

'' iter over areas, adjusting mins and maxs as needed
For iter = 2 To numAreas
With rng.Areas(iter)
If .Item(1).Row < rMin Then Let rMin = .Item(1).Row
If .Item(1).Column < cMin Then Let cMin = .Item(1).Column
If .Item(.Count).Row > rMax Then Let rMax = .Item(.Count).Row
If .Item(.Count).Column > cMax Then Let cMax = .Item(.Count).Column
End With
Next iter

'' output the footprint
With rng.Worksheet
Set footprint = .Range(.Cells(rMin, cMin), .Cells(rMax, cMax))
End With
End Function

• Hi Taylor, thanks a lot for such a structured and detailed answer! I learned about a lot of new properties and methods that I didn't know existed. Commented Sep 16, 2020 at 8:37
• oops, i accidentally submitted the comment -- One problem I encountered using your code is where some rows are hidden/filtered/ I want to sum non-contiguous parts of the same column. It throws an error on evaluating the rsum, since col.Address doesn't seem to store the desired range. I'm sorry that my code was so messy and poorly commented, I'll do better next time. I actually commented out my On Error Goto but pasted a wrong version here, sorry about that as well. I noticed that my ctrl+select must go top left to bottom right or else it will error on my original code's min/max settings. Commented Sep 16, 2020 at 8:46
• I originally planned to loop through but had no idea how to deal with non-contiguous ranges and therefore ended up using the convoluted array method above. This was very helpful! And I'm certainly interested in RegEx matching techniques but I don't have the time to develop that yet, so I did what I could. I'm also curious what sort of selections you did that ended up in errors with my code, if you don't mind going through that Commented Sep 16, 2020 at 8:48
• I'll go ahead and mark this as answered. I only changed the rounded sum to a loop to add up all the values in col in case the col was not contiguous and so far it works perfect! Thanks! Commented Sep 18, 2020 at 3:57