Output the rounded sum of each column in selection

Question

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
 rowslist.Add rng.Row, CStr(rng.Row)
 On Error GoTo 0
 Next rng
 For Each rng In Selection.Areas(z).Columns
 On Error Resume Next
 colslist.Add rng.Column, CStr(rng.Column)
 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 :]

• Mast: Welcome to Code Review!
• Mast: 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.
• dis_array: @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!
• Mast: 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.
• dis_array: 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!

Answer 1

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
 Debug.Print cell.Address
 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
 Debug.Print out.Address
 
 
 
 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
 
 '' Handle bad input
 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

• dis_array: 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.
• dis_array: 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.
• dis_array: 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
• dis_array: 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!