1
\$\begingroup\$

I was trying to give SUMIFS3D User-Defined-Function a nice review and ended up getting pretty side-tracked trying to figure out how to pass some parameters by array and whether or not I could send a 3D-range through the function (seems not).

It's a good one for review, I'm sure there are improvements - I wrote it in about 3 hours.

Function

SUMIF3D(ByVal sum_range As Range, ByVal list_Sheets As String, ByVal criteriaRange As Range, ByVal criteria As Variant, Optional ByVal isNumeric As Boolean = False)

Returns: Long

Input

Something like

=SUMIF3D(D1:D5,"sheet1,sheet2",H1:H5,I1)

To set it up just open a workbook and input:

Sheet1!D1:D5 = 1-5
Sheet2!D1:D5 = 10-50
Sheet1!H1:H5 = 1,5,10,15,20

And whatever arguments you want in Sheet1!I1=I5 e.g.

  • 1 2 5 15 15
  • >0 >10 >=10 <10 20
  • >10

Or try your luck with matching strings.

It works on everything I've tried. It's a bad mama-jama

Option Explicit

Public Function SUMIF3D(ByVal sum_range As Range, ByVal list_Sheets As String, ByVal criteriaRange As Range, ByVal criteria As Variant, Optional ByVal isNumeric As Boolean = False) As Long
    Const OPERATORS As String = ">,<,<>,="
    Dim isPossible As Boolean
    Dim toSum() As Boolean
    Dim i As Long
    Dim j As Long

    Dim sumRangeCells() As Long
    ReDim sumRangeCells(1 To sum_range.Count, 1 To 2)
    Dim cell As Range
    i = 1
    For Each cell In sum_range
        sumRangeCells(i, 1) = cell.Row
        sumRangeCells(i, 2) = cell.Column
        i = i + 1
    Next

    Dim numberOfCells As Long
    Dim sheetsArray As Variant
    sheetsArray = Split(list_Sheets, ",")
    Dim sumRangeArray As Variant
    numberOfCells = (UBound(sheetsArray) + 1) * sum_range.Count
    ReDim sumRangeArray(1 To numberOfCells)

    Dim k As Long
    k = 1
    For i = LBound(sheetsArray) To UBound(sheetsArray)
        For j = 1 To sum_range.Count
            sumRangeArray(k) = Sheets(sheetsArray(i)).Cells(sumRangeCells(j, 1), sumRangeCells(j, 2))
            k = k + 1
        Next
    Next

    Dim critRangeArray As Variant
    critRangeArray = criteriaRange.Value2
    Dim criteriaArray As Variant
    criteriaArray = criteria.Value2

    ReDim toSum(1 To UBound(critRangeArray, 1))
    If Not IsArray(criteriaArray) Then
        If IsEmpty(criteriaArray) Then
            isPossible = False
        Else: isPossible = True
        End If
    Else
        If Not UBound(criteriaArray, 1) = UBound(critRangeArray, 1) Then
            isPossible = False
        Else: isPossible = True
        End If
    End If

    If Not isPossible Then Exit Function

    Select Case isNumeric
        Case 1
            If IsArray(criteriaArray) Then
                For i = 1 To UBound(critRangeArray)
                    If InStr(1, OPERATORS, Left$(criteriaArray(i, 1), 1)) > 0 Then
                        toSum(i) = Application.Evaluate(critRangeArray(i, 1) & criteriaArray(i, 1))
                    Else: toSum(i) = critRangeArray(i, 1) = criteriaArray(i, 1)
                    End If
                Next
            Else
                For i = 1 To UBound(critRangeArray)
                        If InStr(1, OPERATORS, Left$(criteriaArray, 1)) > 0 Then
                            toSum(i) = Application.Evaluate(critRangeArray & criteriaArray)
                        Else: toSum(i) = critRangeArray(i, 1) = criteriaArray
                        End If
                Next
            End If
        Case 0
            If IsArray(criteriaArray) Then
                For i = 1 To UBound(critRangeArray)
                    toSum(i) = critRangeArray(i, 1) = criteriaArray(i, 1)
                Next
            Else
                For i = 1 To UBound(critRangeArray)
                    toSum(i) = critRangeArray(i, 1) = criteriaArray
                Next
            End If
    End Select

    For j = LBound(sheetsArray) To UBound(sheetsArray)
        For i = 1 To UBound(toSum)
            If toSum(i) Then SUMIF3D = SUMIF3D + sumRangeArray(i + j * UBound(toSum))
        Next
    Next
End Function
\$\endgroup\$

2 Answers 2

1
\$\begingroup\$

A couple of things I have noticed (and I haven't tested the code):

  • If you make the return value a Variant, instead of Long, you can also pass Excel Errors (e.g. #VALUE!) as a result from the UDF. This would be particular useful if IfPossible is False.
  • You set OPERATORS up as a constant so you can check the validity of an input. But you don't use the string position at all. So, instead of Const OPERATORS As String = ">,<,<>,=", you can simply have Const OPERATORS As String = "<>=" which covers <, >, <> and =.
  • Having set and used OPERATORS, you only check the 1st character, so <> will never be matched.
  • You don't want to check for <= and `>=' as well?

Codewise:

    If Not UBound(criteriaArray, 1) = UBound(critRangeArray, 1) Then
        isPossible = False
    Else: isPossible = True
    End If

Can be simplified to

isPossible = (UBound(criteriaArray, 1) = UBound(critRangeArray, 1))

Similarily:

If IsEmpty(criteriaArray) Then
    isPossible = False
Else: isPossible = True
End If

can be simplified to:

isPossible = Not IsEmpty(criteriaArray)

That entire If-Then-Else block can become:

If Not IsArray(criteriaArray) Then
    isPossible = Not IsEmpty(criteriaArray)
Else
    isPossible = (UBound(criteriaArray, 1) = UBound(critRangeArray, 1))
End If

Which, of course, you can turn around to get rid of the Not

If IsArray(criteriaArray) Then
    isPossible = (UBound(criteriaArray, 1) = UBound(critRangeArray, 1))
Else
    isPossible = Not IsEmpty(criteriaArray)
End If

Missing something here: Select Case isNumeric. That is not how the IsNumeric(val as variant) function is used. And given this is a Boolean result, a simple if-then statement will work. I am surprised this runs without throwing an error (I am taking your word for it that it works).

I am not going to go through it here (this answer is now long enough), but that case statement needs some serious rework. You have a lot of repetition and could probably get rid of at least two levels of nesting.

\$\endgroup\$
3
  • \$\begingroup\$ Yeah, the numeric function has a bad name, bad me using a system name as a variable. IsNumericalTest would be better. One thing I did run into is that I don't want to default of my boolean to be True, hence all the Else: True. Thank you \$\endgroup\$ Mar 20, 2018 at 5:59
  • \$\begingroup\$ @Raystafarian: Understand not wanting to default Booleans, but the code I suggested above sets isPossible to either True or False - no defaults :-) \$\endgroup\$
    – AJD
    Mar 20, 2018 at 6:03
  • \$\begingroup\$ Yes it's much better \$\endgroup\$ Mar 20, 2018 at 6:04
1
\$\begingroup\$

Here's what I noticed:

  • Right now, you're looping through each cell in the sum range for each sheet and writing the results to an array. You actually do 3 reads per cell (once for Row, once for Column, once for Value2) on the sheet explicitly referenced by the range. This is really only necessary if the sum range is non-contiguous; otherwise, it's much faster to read in the entire range for each sheet. I'd change the function to either not accept non-contiguous ranges, or explicitly test to see if the range is non-contiguous. That way you could get good performance with normal use-cases (contiguous ranges) and still stay flexible. Something like this:

    Function isContiguous(ByRef rng As Range) As Boolean
    
        Dim returnVal As Boolean
        returnVal = False
    
        If rng.Areas.Count = 1 Then
            returnVal = True
        Else
            Dim rngArea As Range
            Dim rngUnion As Range
            For Each rngArea In rng.Areas
                If rngUnion Is Nothing Then
                    Set rngUnion = rngArea
                Else
                    Set rngUnion = Union(rngArea, rngUnion)
                End If
            Next
            If rngUnion.Areas.Count = 1 Then
                returnVal = True
            End If
        End If
    
        isContiguous = returnVal
    
    End Function
    
  • Since the sheet names are passed as a string, there's no guarantee that they actually exist. I'd probably test that before doing anything else in the function, and exit (or return some sort of descriptive error message) if any of the sheets don't exist. Here's a version of the sheet existence function that I use:

    Function sheetsExist(wb As Workbook, ByVal wsNames As Variant) As Boolean
    
        Dim i As Long
        Dim j As Long
    
        ReDim existingSheets(1 To wb.Sheets.Count) As Variant
        For i = LBound(existingSheets) To UBound(existingSheets)
            existingSheets(i) = UCase(wb.Sheets(i).Name)
        Next
    
        Dim toTest As Variant
        toTest = IIf(IsArray(wsNames), wsNames, Array(wsNames))
    
        For i = LBound(toTest) To UBound(toTest)
            Dim uStr As String
            Dim goAhead As Boolean
            uStr = UCase(toTest(i))
            goAhead = False
    
            For j = LBound(existingSheets) To UBound(existingSheets)
                If uStr = existingSheets(j) Then
                    goAhead = True
                    Exit For
                End If
            Next
    
            If Not goAhead Then
                sheetsExist = False
                Exit Function
            End If
        Next
    
        sheetsExist = True
    
    End Function
    
  • Your "criteria" parameter is passed as a Variant, but the first time it's accessed you reference its Value2 property, which only applies to Range objects. I'd either change the parameter type to Range, or test the parameter's type if you want the user to also be able to pass a comma-delimited string of criteria.

    If TypeName(criteria) = "Range" Then
        'Convert to array with .Value2
    ElseIf TypeName(criteria) = "String" Then
        'Convert to array with Split
    Else
        Exit Function
    End If
    
  • Along those lines, something I've found helpful when writing functions that accept a variety of inputs for a single parameter (ie a Range, a String, an array of Strings) is to have some way of converting those inputs to a consistent format. That way, whether you're passed a reference to a single cell, a dozen cells, a single string, or an array of strings, they all turn into the same thing: a 1d array of base 1 (or 0, if you prefer). Here's a short function I wrote that looks like it could do that for both the "criteria" and "list_sheets" parameters so that they could accept a variety of input types. It uses one helper function for changing the base of 1d/2d arrays, and another for converting a "narrow" 2d array (ie with dimensions "1 to 10, 1 To 1" or "1 to 1, 1 to 10") into a 1d array (ie "1 to 10"). I use those two functions constantly so that I know that the arrays I'm working with will be predictable.

    Function convertParam(paramRef As Variant) As Variant
    
        'If passed range, convert to 1D array (base 1) of values
        If TypeName(paramRef) = "Range" Then
            convertParam = narrow2dArray(paramRef.Value2)
        'If passed array, convert to base 1
        ElseIf IsArray(paramRef) Then
            convertParam = changeArrayBase(paramRef)
        'If passed string, split and convert to base 1
        ElseIf TypeName(paramRef) = "String" Then
            convertParam = changeArrayBase(Split(paramRef, ","))
        End If
    
    End Function
    Function changeArrayBase(ByVal arr As Variant, Optional ByVal newBase As Long = 1) As Variant
    'Changes base of 1D or 2D array (arr) to specified value (newBase)
    'If arr is not an array, it is turned into a 1-element array containing the original value
    
        Dim tempArr As Variant
        Dim i As Long
        Dim j As Long
        Dim numDims As Long
        numDims = getDims(arr)
    
        If numDims = 0 Then
            ReDim tempArr(newBase To newBase) As Variant
            If IsObject(arr) Then
                Set tempArr(newBase) = arr
            Else
                tempArr(newBase) = arr
            End If
        ElseIf numDims = 1 Then
            ReDim tempArr(newBase To UBound(arr) - LBound(arr) + newBase) As Variant
            j = newBase
            For i = LBound(arr) To UBound(arr)
                If IsObject(arr(i)) Then
                    Set tempArr(j) = arr(i)
                Else
                    tempArr(j) = arr(i)
                End If
                j = j + 1
            Next
        ElseIf numDims > 2 Then
            Exit Function
        Else
            Dim x As Long
            Dim y As Long
            x = UBound(arr, 1) - LBound(arr, 1) + newBase
            y = UBound(arr, 2) - LBound(arr, 2) + newBase
            ReDim tempArr(newBase To x, newBase To y) As Variant
            x = newBase
            For i = LBound(arr, 1) To UBound(arr, 1)
                y = newBase
                For j = LBound(arr, 2) To UBound(arr, 2)
                    If IsObject(arr(i, j)) Then
                        Set tempArr(x, y) = arr(i, j)
                    Else
                        tempArr(x, y) = arr(i, j)
                    End If
                    y = y + 1
                Next
                x = x + 1
            Next
        End If
    
        changeArrayBase = tempArr
    
    End Function
    Function narrow2dArray(ByRef arr As Variant, Optional ByVal newBase As Long = 1) As Variant
    'Takes a 2d array which has one dimension of size 1 and converts it to a 1d array with base newBase
    'IE it takes an array with these dimensions:
        'Dim arr(1 To 10, 1 To 1)
    'And turns it into an array with these dimensions:
        'Dim arr(1 To 10)
    
        Dim bigDim As Integer
        Dim smallDim As Integer
        Dim numDims As Long
        numDims = getDims(arr)
    
        If numDims = 0 Then
            ReDim smallArr(newBase To newBase) As Variant
            smallArr(newBase) = arr
            narrow2dArray = smallArr
            Exit Function
        ElseIf numDims = 1 Then
            narrow2dArray = arr
            Exit Function
        ElseIf numDims > 2 Then
            Exit Function
        ElseIf LBound(arr, 1) = UBound(arr, 1) Then
            bigDim = 2
            smallDim = 1
        ElseIf LBound(arr, 2) = UBound(arr, 2) Then
            bigDim = 1
            smallDim = 2
        Else
            Exit Function
        End If
    
        ReDim tempArr(newBase To UBound(arr, bigDim) - LBound(arr, bigDim) + newBase) As Variant
    
        Dim i As Long
        Dim j As Long
        Dim k As Long
        j = LBound(arr, bigDim)
        k = LBound(arr, smallDim)
        If bigDim = 2 Then
            For i = LBound(tempArr) To UBound(tempArr)
                If IsObject(arr(k, j)) Then
                    Set tempArr(i) = arr(k, j)
                Else
                    tempArr(i) = arr(k, j)
                End If
                j = j + 1
            Next
        Else
            For i = LBound(tempArr) To UBound(tempArr)
                If IsObject(arr(j, k)) Then
                    Set tempArr(i) = arr(j, k)
                Else
                    tempArr(i) = arr(j, k)
                End If
                j = j + 1
            Next
        End If
    
        narrow2dArray = tempArr
    
    End Function
    Function getDims(x As Variant) As Long
    'Gets number of dimensions of array
    'If passed non-array, returns 0
    
        On Error GoTo Err
    
        Dim i As Long
        Dim tempVal As Long
        i = 0
        Do While True
            i = i + 1
            tempVal = UBound(x, i)
        Loop
    
    Err:
        On Error GoTo 0
        getDims = i - 1
    End Function
    
\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.

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