By Myrna Larson and David Hager
Presented below are 3 UDF’s (SumProduct3D, SumIf3D, CountIf3D) that
provide a useful method of returning a variety of information from 3D
ranges. Each of these functions use a 3D range argument (written as per
the usual Excel protocol) as a string. This string is processed by the
Parse3DRange function, which returns sheet positions and the range argument
in variables that are used by these functions.
Function SumProduct3D(Range3D As String, Range_B As Range) _
As Variant
Dim sRangeA As String
Dim sRangeB As String
Dim Sheet1 As Integer
Dim Sheet2 As Integer
Dim Sum As Double
Dim n As Integer
Application.Volatile
If Parse3DRange(Application.Caller.Parent.Parent.Name, _
Range3D, Sheet1, Sheet2, sRangeA) = False Then
SumProduct3D = CVErr(xlErrRef)
Exit Function
End If
sRangeB = Range_B.Address
Sum = 0
For n = Sheet1 To Sheet2
With Worksheets(n)
Sum = Sum + Application.WorksheetFunction.SumProduct( _
.Range(sRangeA), .Range(sRangeB))
End With
Next
SumProduct3D = Sum
End Function
Function SumIf3D(Range3D As String, Criteria As String, _
Optional Sum_Range As Variant) As Variant
Dim sTestRange As String
Dim sSumRange As String
Dim Sheet1 As Integer
Dim Sheet2 As Integer
Dim n As Integer
Dim Sum As Double
Application.Volatile
If Parse3DRange(Application.Caller.Parent.Parent.Name, _
Range3D, Sheet1, Sheet2, sTestRange) = False Then
SumIf3D = CVErr(xlErrRef)
End If
If IsMissing(Sum_Range) Then
sSumRange = sTestRange
Else
sSumRange = Sum_Range.Address
End If
Sum = 0
For n = Sheet1 To Sheet2
With Worksheets(n)
Sum = Sum + Application.WorksheetFunction.SumIf(.Range _
(sTestRange), Criteria, .Range(sSumRange))
End With
Next n
SumIf3D = Sum
End Function
Function CountIf3D(Range3D As String, Criteria As String) _
As Variant
Dim Sheet1 As Integer
Dim Sheet2 As Integer
Dim sTestRange As String
Dim n As Integer
Dim Count As Long
Application.Volatile
If Parse3DRange(Application.Caller.Parent.Parent.Name, _
Range3D, Sheet1, Sheet2, sTestRange) = False Then
CountIf3D = CVErr(xlErrRef)
Exit Function
End If
Count = 0
For n = Sheet1 To Sheet2
With Worksheets(n)
Count = Count + Application.WorksheetFunction.CountIf( _
.Range(sTestRange), Criteria)
End With
Next n
CountIf3D = Count
End Function
Function Parse3DRange(sBook As String, SheetsAndRange _
As String, FirstSheet As Integer, LastSheet As Integer, _
sRange As String) As Boolean
Dim sTemp As String
Dim i As Integer
Dim Sheet1 As String
Dim Sheet2 As String
Parse3DRange = False
On Error GoTo Parse3DRangeError
sTemp = SheetsAndRange
i = InStr(sTemp, “!”)
If i = 0 Then Exit Function
‘next line will generate an error if range is invalid
‘if it’s OK, it will be converted to absolute form
sRange = Range(Mid$(sTemp, i + 1)).Address
sTemp = Left$(sTemp, i – 1)
i = InStr(sTemp, “:”)
Sheet2 = Trim(Mid$(sTemp, i + 1))
If i > 0 Then
Sheet1 = Trim(Left$(sTemp, i – 1))
Else
Sheet1 = Sheet2
End If
‘next lines will generate errors if sheet names are invalid
With Workbooks(sBook)
FirstSheet = .Worksheets(Sheet1).Index
LastSheet = .Worksheets(Sheet2).Index
‘swap if out of order
If FirstSheet > LastSheet Then
i = FirstSheet
FirstSheet = LastSheet
LastSheet = i
End If
i = .Worksheets.Count
If FirstSheet >= 1 And LastSheet < = i Then
Parse3DRange = True
End If
End With
Parse3DRangeError:
On Error GoTo 0
Exit Function
End Function ‘Parse3DRange
Editor’s Note: I didn’t like that the second argument was a range that had to mirror the 3D-ness of the first string-range. I change the parsing function to return an array of ranges so that you could put any two equally sized ranges in as arguments and one, both, or neither have to be 3D. The downside is that both arguments have to be strings.
Function SumProduct3D2(sRng1 As String, sRng2 As String) _
As Variant
Dim vaRng1 As Variant, vaRng2 As Variant
Dim rTemp As Range
Dim i As Long
Dim Sum As Double
Dim rCell As Range
Application.Volatile
vaRng1 = Parse3DRange2(Application.Caller.Parent.Parent, sRng1)
vaRng2 = Parse3DRange2(Application.Caller.Parent.Parent, sRng2)
For i = LBound(vaRng1) To UBound(vaRng1)
Sum = Sum + (vaRng1(i).Value * vaRng2(i).Value)
Next i
SumProduct3D2 = Sum
End Function
Function SumIf3D2(Range3D As String, Criteria As String, _
Optional Sum_Range As String) As Variant
Dim Sum As Double
Dim vaRng1 As Variant, vaRng2 As Variant
Dim i As Long
Application.Volatile
If Len(Sum_Range) = 0 Then
Sum_Range = Range3D
End If
vaRng1 = Parse3DRange2(Application.Caller.Parent.Parent, Range3D)
vaRng2 = Parse3DRange2(Application.Caller.Parent.Parent, Sum_Range)
Sum = 0
For i = LBound(vaRng1) To UBound(vaRng1)
Sum = Sum + Application.WorksheetFunction.SumIf(vaRng1(i), Criteria, vaRng2(i))
Next i
SumIf3D2 = Sum
End Function
Function CountIf3D2(Range3D As String, Criteria As String) _
As Variant
Dim i As Long
Dim Count As Long
Dim vaRng1 As Variant
Application.Volatile
vaRng1 = Parse3DRange2(Application.Caller.Parent.Parent, Range3D)
Count = 0
For i = LBound(vaRng1) To UBound(vaRng1)
Count = Count + Application.WorksheetFunction.CountIf(vaRng1(i), Criteria)
Next i
CountIf3D2 = Count
End Function
Function Parse3DRange2(wb As Workbook, _
SheetsAndRange As String) As Variant
Dim sTemp As String
Dim i As Long, j As Long
Dim Sheet1 As String, Sheet2 As String
Dim aRange() As Range
Dim sRange As String
Dim lFirstSht As Long, lLastSht As Long
Dim rCell As Range
Dim rTemp As Range
On Error GoTo Parse3DRangeError
sTemp = SheetsAndRange
‘if it’s 3d, rtemp will be nothing
On Error Resume Next
Set rTemp = Range(sTemp)
On Error GoTo Parse3DRangeError
‘if it’s 3d, parse it
If rTemp Is Nothing Then
i = InStr(sTemp, “!”)
If i = 0 Then Err.Raise 9999
‘next line will generate an error if range is invalid
‘if it’s OK, it will be converted to absolute form
sRange = Range(Mid$(sTemp, i + 1)).Address
sTemp = Left$(sTemp, i – 1)
i = InStr(sTemp, “:”)
Sheet2 = Trim(Mid$(sTemp, i + 1))
If i > 0 Then
Sheet1 = Trim(Left$(sTemp, i – 1))
Else
Sheet1 = Sheet2
End If
‘next lines will generate errors if sheet names are invalid
With wb
lFirstSht = .Worksheets(Sheet1).Index
lLastSht = .Worksheets(Sheet2).Index
‘swap if out of order
If lFirstSht > lLastSht Then
i = lFirstSht
lFirstSht = lLastSht
lLastSht = i
End If
‘load each cell into an array
j = 0
For i = lFirstSht To lLastSht
For Each rCell In .Sheets(i).Range(sRange)
ReDim Preserve aRange(0 To j)
Set aRange(j) = rCell
j = j + 1
Next rCell
Next i
End With
Parse3DRange2 = aRange
Else
‘range isn’t 3d, so just load each cell into array
For Each rCell In rTemp.Cells
ReDim Preserve aRange(0 To j)
Set aRange(j) = rCell
j = j + 1
Next rCell
Parse3DRange2 = aRange
End If
Parse3DRangeError:
On Error GoTo 0
Exit Function
End Function ‘Parse3DRange
