# VBA UDF SUMIF with Array Parameters

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


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.

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

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
uStr = UCase(toTest(i))

For j = LBound(existingSheets) To UBound(existingSheets)
If uStr = existingSheets(j) Then
Exit For
End If
Next

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
`