2
\$\begingroup\$

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

\$\endgroup\$
  • 1
    \$\begingroup\$ Welcome to Code Review! \$\endgroup\$ – Mast Sep 7 at 8:10
  • 2
    \$\begingroup\$ 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. \$\endgroup\$ – Mast Sep 16 at 9:39
  • \$\begingroup\$ @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! \$\endgroup\$ – dis_array Sep 16 at 9:44
  • \$\begingroup\$ 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. \$\endgroup\$ – Mast Sep 16 at 9:47
  • \$\begingroup\$ 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! \$\endgroup\$ – dis_array Sep 16 at 9:50
3
\$\begingroup\$

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
| improve this answer | |
\$\endgroup\$
  • \$\begingroup\$ 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. \$\endgroup\$ – dis_array Sep 16 at 8:37
  • \$\begingroup\$ 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. \$\endgroup\$ – dis_array Sep 16 at 8:46
  • \$\begingroup\$ 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 \$\endgroup\$ – dis_array Sep 16 at 8:48
  • \$\begingroup\$ 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! \$\endgroup\$ – dis_array Sep 18 at 3:57

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.