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
