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