Determine unique values on a filtered column in a table

[RawlinsCross]

So I have a table that I've filtered, and my understanding is that you have to deal with areas in such cases although I'm not terribly experienced in dealing with areas. What I want to do is that if the 5th column of a filtered list has only one unique value a certain subroutine will fire and if there are more than one unique value another subroutine will fire. It's not working out for me at the moment. Here's my attempt at the code. (The IsArrayAllocated is from CPearson's page)

Dim wSht As Worksheet
Dim rRange As Range, rng As Range, rFinal As Range
Dim vArray As Variant

Set wSht = ThisWorkbook.Worksheets("Schedule")
Set rRange = wSht.Range("rngSchedule").Columns(5).SpecialCells(xlCellTypeVisible)

For Each rng In rRange.Areas
    If rFinal Is Nothing Then
        Set rFinal = rng
    Else
        Set rFinal = Union(rFinal, rng)
    End If
Next rng

On Error Resume Next
vArray = Application.WorksheetFunction.Unique(rFinal)  'This will error if there are no duplicates and the code will follow the "ELSE" logic.
On Error GoTo 0

If IsArrayAllocated(vArray) Then
    Set rRange = wSht.Rows(6)
    rRange.ClearContents
    Exit Sub
Else
    Application.ScreenUpdating = False
    Call PlacePCTOnCalcWS
    Application.ScreenUpdating = True
End If

End Sub

Public Function IsArrayAllocated(arr As Variant) As Boolean

On Error Resume Next
IsArrayAllocated = IsArray(arr) And Not IsError(LBound(arr, 1)) And LBound(arr, 1) <= UBound(arr, 1)

End Function

 

[Domenic]

It looks like the error is caused when rFinal refers to a non-contiguous range of cells, not when there are no duplicates. Try using the Dictionary object instead, maybe something like this...

    Dim dic As Object
    Dim wSht As Worksheet
    Dim rRange As Range, rng As Range, rCell As Range
    Dim vArray As Variant
    
    Set wSht = ThisWorkbook.Worksheets("Schedule")
    
    On Error Resume Next
    Set rRange = wSht.Range("rngSchedule").Columns(5).SpecialCells(xlCellTypeVisible)
    If rRange Is Nothing Then
        MsgBox "No records found!", vbExclamation
        Exit Sub
    End If
    On Error GoTo 0
        
    Set dic = CreateObject("Scripting.Dictionary")
    
    dic.comparemode = 1 'vbTextCompare
    
    For Each rng In rRange.Areas
        For Each rCell In rng
            dic(rCell.Value) = ""
        Next rCell
    Next rng
    
    If dic.Count > 1 Then
        'do something
    Else
        'do something else
    End If

Hope this helps!

 

[RawlinsCross]

Hey Dominic, excuse the delay - been away for a bit clearly. Thanks for your input. Makes sense that a dictionary is the go-to in this case. Works like a charm. Cheers

 

[Domenic]

That's great, I'm glad I could help.

And thanks for your feedback.

Cheers!