Function CountIf3D(rgToCheck, Criteria As Variant) As Variant
'Function works just like COUNTIF function, except can handle 3-D cell range references
'rgToCheck may be single sheet or multi-sheet references to one or more cells _
Enter 3-D ranges just like in a SUM formula: =CountIf3D('Sheet 1:Sheet 3'!A1:A7, ">0")
'Criteria may be a single value or an array of values
'Function returns the count of matching values if Criteria is a single value. It returns an array of counts if Criteria is an array. _
=CountIf3D('Sheet 1:Sheet 3'!A1:A7, ">0") returns a single value _
=CountIf3D('Sheet 1:Sheet 3'!A1:A7, {">5", "<2"}) returns a two column array of values _
=CountIf3D('Sheet 1:Sheet 3'!A1:A7, {">5"; "<2"}) returns a two row array of values (semicolon instead of comma in array constant) _
=CountIf3D('Sheet 1:Sheet 3'!A1:A7, {">5", ">20"; "<2", "<1"}}) returns a two column by two row array of values _
=CountIf3D('Sheet 1'!A1:A7, ">0") works just like a COUNTIF formula
'Note: there must be only one CountIf3D function in a formula--the wrong answer will be returned if there is more than one.
Dim cel As Range
Dim i As Long, j As Long, n As Long, nCols As Long, nRows As Long
Dim iFirstCheck As Integer, iLastCheck As Integer, k As Integer
Dim vCheck As Variant, vCriteria As Variant, vResults() As Variant
Dim wbCheck As Workbook
On Error Resume Next
Set cel = Application.Caller
If cel Is Nothing Then
CountIf3D = "#NoRange"
Exit Function
End If
vCheck = Parse3D(cel.Cells(1), "CountIf3D", 1)
Set wbCheck = Workbooks(vCheck(0))
iFirstCheck = wbCheck.Worksheets(vCheck(1)).Index
iLastCheck = wbCheck.Worksheets(vCheck(2)).Index
If VarType(Criteria) >= vbArray Then
nCols = UBound(Criteria)
nRows = UBound(Criteria, 2)
If nCols = 0 Then nCols = 1
If nRows = 0 Then nRows = 1
ReDim vResults(1 To nRows, 1 To nCols)
Else
ReDim vResults(1 To 1, 1 To 1)
n = 1
nRows = 1
nCols = 1
End If
n = nRows * nCols
On Error GoTo 0
For i = 1 To nRows
For j = 1 To nCols
If n = 1 Then
vCriteria = Criteria
Else
If nCols = 1 Then
vCriteria = Criteria(i)
ElseIf nRows = 1 Then
vCriteria = Criteria(j)
Else
vCriteria = Criteria(i, j)
End If
End If
If VarType(rgToCheck) = 10 Then
For k = iFirstCheck To iLastCheck
vResults(i, j) = vResults(i, j) + Application.CountIf(wbCheck.Worksheets(k).Range(vCheck(3)), vCriteria)
Next
Else
vResults(i, j) = Application.CountIf(rgToCheck, vCriteria)
End If
Next
Next
CountIf3D = vResults
End Function
Private Function Parse3D(FormulaCell As Range, fnName As String, parmIndex As Integer) As Variant
'Parses a formula looking for a specified function. If found, returns a variant array containing four strings: _
workbook name, first worksheet name, last worksheet name and range address. _
'Function tolerates commas in workbook or sheet names, array constants and range unions
'FormulaCell is a range variable pointing to the cell that contains the 3D formula
'fnName is the name of the 3D function, e.g. CountIf3D, SumIf3D, VLookup3D
'parmIndex is the index number of the parameter desired from the calling function
Dim i As Integer, i1 As Integer, i2 As Integer, i3 As Integer, j As Integer, k As Integer, n As Integer
Dim firstSheet As String, frmla As String, lastSheet As String, sPlaceHolder As String, sRange As String, _
sSeparator As String, sSheets As String, sWorkbook As String, s1 As String, s2 As String
Dim nm As Name
Dim wb As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
sSeparator = "," 'The .Formula property uses a comma as list separator, no matter what the regional setting
sPlaceHolder = "?" 'This can be any character not found in workbook or worksheet names
frmla = FormulaCell.Formula
j = InStr(1, UCase(frmla), UCase(fnName) & "(")
If j > 0 Then
sSheets = Mid(frmla, j + Len(fnName) + 1)
'Eliminate any list separators that might be embedded in the formula
For i = 0 To 4
s1 = Array("'", """", "(", "{", "[")(i)
s2 = Array("'", """", ")", "}", "]")(i)
i1 = InStr(1, sSheets, s1)
Do Until i1 = 0
i2 = InStr(i1 + 1, sSheets, s2)
If i <= 1 And Mid(sSheets, i2, 2) = (s1 & s1) Then i2 = InStr(i2 + 2, sSheets, s1)
If i2 > 0 Then
i3 = InStr(i1, sSheets, sSeparator)
Select Case i3
Case 0
Case Is < i2
sSheets = Left(sSheets, i1) & Replace(Mid(sSheets, i1 + 1, i2 - i1 - 1), sSeparator, sPlaceHolder) & Mid(sSheets, i2)
End Select
i1 = InStr(i2 + 1, sSheets, s1)
End If
Loop
Next
sSheets = Split(sSheets, sSeparator)(parmIndex - 1)
sSheets = Replace(sSheets, sPlaceHolder, sSeparator) 'Restore any list separators that had temporarily been replaced with placeholder
If Right(sSheets, 1) = ")" Then sSheets = Left(sSheets, Len(sSheets) - 1)
'Test whether parameter is a named range
On Error Resume Next
Set nm = FormulaCell.Parent.Names(sSheets)
If nm Is Nothing Then Set nm = FormulaCell.Parent.Parent.Names(sSheets)
On Error GoTo 0
If Not nm Is Nothing Then sSheets = Mid(nm.RefersTo, 2) 'Delete the initial = sign
sSheets = Replace(sSheets, "''", "'") 'Single quotes embedded within sheet names are doubled up to escape them
k = InStrRev(sSheets, "!")
If k = 0 Then
sRange = sSheets
firstSheet = FormulaCell.Worksheet.Name
lastSheet = FormulaCell.Worksheet.Name
Else
sRange = Mid(sSheets, k + 1)
sSheets = Left(sSheets, k - 1)
k = InStr(1, sSheets, "]")
If k > 0 Then
sWorkbook = Split(sSheets, "]")(0)
If Left(sWorkbook, 1) = "'" Then sWorkbook = Mid(sWorkbook, 2)
If Left(sWorkbook, 1) = "[" Then sWorkbook = Mid(sWorkbook, 2)
sSheets = Split(sSheets, "]")(1)
End If
If Left(sSheets, 1) = "'" Then sSheets = Mid(sSheets, 2)
If Right(sSheets, 1) = "'" Then sSheets = Left(sSheets, Len(sSheets) - 1)
k = InStr(1, sSheets, ":")
If k = 0 Then
firstSheet = sSheets
lastSheet = sSheets
Else
firstSheet = Split(sSheets, ":")(0)
lastSheet = Split(sSheets, ":")(1)
End If
End If
If sWorkbook = "" Then sWorkbook = FormulaCell.Worksheet.Parent.Name
Parse3D = Array(sWorkbook, firstSheet, lastSheet, sRange)
End If
End Function
![[glasses]](/data/assets/smilies/glasses.gif "[glasses] [glasses]")
Just traded in my old subtlety...![[tongue]](/data/assets/smilies/tongue.gif "[tongue] [tongue]")