Compiling Occurrances from a group of Cells

Public Function FORMATRNG(ByVal Criteria As Range, ByVal ComparisonType As Long, ParamArray Target() As Variant) As Range
'Created by Parry including improvements offered by Juan Pablo González & Daniel Klann
'Function returns a range that matches the format criteria. The function is designed to
'be used within other functions so is very flexible. Limited testing in XL2002.
'This function WILL NOT evaluate cells that have been formatted as a result of
'Conditional Formatting.

'***** EXPLANATION OF ARGUMENTS AND SYNTAX ***************
'CriteriaRange:  A single cell that has the desired format for comparison. The cell may be
'any cell including the cell that contains the FormatRng formula.
'ComparisonType:  Number representing type of format to evaluate. Select from the following list.
'0 = Compare Interior Colour
'1 = Compare Bold Font
'2 = Compare Italics
'3 = Compare Font Size
'4 = Compare Font Colour
'5 = Compare Font Name (Arial, Times New Roman etc)
'6 = Compare Underline
'TargetRange: Range/s to evaluate. This may be non-contiguous cells so you may select
'multiple ranges to evaluate. Separate each range with a comma.
'EG: =SUM(FORMATRNG(B1, 1, A1:A10,C1:C10)) returns a range that matches BoldFont value (ie
'True or False)in cell B1 against the cells A1:A10 & C1:C10 & sums the result. If B1 is
'Bold then the range will be those cells in A1:A10 & C1:C10 that are bold & visa versa
'if B1 isnt Bold.
'*********************************************************

    Dim c As Range, Rng As Range
    Dim Crit As Variant
    Dim Add As Boolean
    Dim vItem As Variant
    Dim rngTarget As Range

'Criteria Cell must only be one cell
    If Criteria.Cells.Count <> 1 Then Exit Function
    Application.Volatile

'Merge the target ranges into one range
    For Each vItem In Target
        If rngTarget Is Nothing Then
            Set rngTarget = vItem
        Else
            Set rngTarget = Application.Union(rngTarget, vItem)
        End If
    Next vItem

'Ignore blank cells
    Set rngTarget = Application.Intersect(rngTarget, rngTarget.Parent.UsedRange)

'Assign type of formatting to look for
    If ComparisonType = 0 Then
        Crit = Criteria.Interior.Color
    Else
        Crit = CallByName(Criteria.Font, Choose(ComparisonType, "Bold", "Italic", "Size", "Color", "Name", "Underline"), VbGet)
    End If

'Look for matches
    For Each c In rngTarget.Cells
        Add = False
        If ComparisonType = 0 Then
            If c.Interior.Color = Crit Then
                Add = True
            End If
        Else
            If CallByName(c.Font, Choose(ComparisonType, "Bold", "Italic", "Size", "Color", "Name", "Underline"), VbGet) = Crit Then
                Add = True
            End If
        End If
'Join cells that match criteria into a range
        If Add Then
            If Rng Is Nothing Then
                Set Rng = c
            Else
                Set Rng = Union(Rng, c)
            End If
        End If
    Next c
'Return range that matches criteria
    Set FORMATRNG = Rng
End Function

Option Base 1
Function test(myRange As Range) As String
    Dim myString As String
    Dim i As Double
    Dim x
    Dim y As Double
    Dim z As Double
    Dim myCell As Range
    Set myCell = myRange.Cells(1)
        y = WorksheetFunction.CountIf(myRange, myCell)
        ReDim x(1)
        x(1) = myCell.Value & " = " & y
    Set myCell = Nothing
    For Each myCell In myRange
        y = WorksheetFunction.CountIf(myRange, myCell)
        On Error Resume Next
        i = WorksheetFunction.Match(myCell.Value & " = " & y, x, 0)
        If Err.Number <> 0 Then
            z = UBound(x)
            ReDim Preserve x(1 To z + 1)
            x(UBound(x)) = myCell.Value & " = " & y
        End If
        On Error GoTo 0
    Next myCell
    myString = x(1)
    For i = LBound(x) + 1 To UBound(x)
        myString = myString & ", " & Chr(10) & x(i)
    Next i
    test = myString
End Function