VBA UDF SUMIF with Array Parameters

Question

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

Answer 1

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.

Answer 2

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