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.

• Raystafarian: 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
• AJD: @Raystafarian: Understand not wanting to default Booleans, but the code I suggested above sets isPossible to either True or False - no defaults :-)
• Raystafarian: Yes it's much better

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