CODEWITHSUNDEEP
excelvba
Josh Marks
Josh Marks

Reputation: 79

Find Unique Values In Column from Worksheet with Autofilter

I have autofiltered a worksheet and am trying to establish the unique values within the filtered data. I feel like I have the correct approach, but the my results only show 2 of the possible 8 unique values.

Private Sub GetAllCampusDomains(DomainCol As Collection)
    Dim data(), dict As Object, r As Long, i%, lastrow As Long
    Set dict = CreateObject("Scripting.Dictionary")
       
    'Clear the previous filter
    shtData.ShowAllData
    
    'Filter the data
    shtData.Range("A:Y").AutoFilter Field:=6, Criteria1:=shtSetup.Range("CampusName") 'SchoolName
    shtData.Range("A:Y").AutoFilter Field:=9, Criteria1:="DomainPerformance" 'ColI
           
    'Inspect the visible cells in ColP
    lastrow = shtData.Cells(shtData.Rows.Count, "P").End(xlUp).row
    data = shtData.Range("P2:P" & lastrow).SpecialCells(xlCellTypeVisible)
    
    'Find the unique values
    For r = 1 To UBound(data)
        dict(data(r, 1)) = Empty
    Next
    data = WorksheetFunction.Transpose(dict.keys())
    
    'Walk through the unique values
    For i = 1 To UBound(data)
        Debug.Print data(i, 1)
        'DomainCol.Add data(i, 1)
    Next i
End Sub

The error seems to have to do with this line: data = shtData.Range("P2:P" & lastrow).SpecialCells(xlCellTypeVisible)

This call only seems to create a 90x1 sized array, when it should be much bigger.

I greatly appreciate your help! Josh

Upvotes: 1

Views: 138

Answers (2)

VBasic2008
VBasic2008

Reputation: 54807

Non-Contiguous Column Range to Jagged Array

Instead of...

data = shtData.Range("P2:P" & lastrow).SpecialCells(xlCellTypeVisible)

'Find the unique values
For r = 1 To UBound(data)
    dict(data(r, 1)) = Empty
Next

...use the following...

Private Sub GetAllCampusDomains(DomainCol As Collection)
    
    '...
    
    Dim rng As Range
    Set rng = shtData.Range("P2:P" & lastrow).SpecialCells(xlCellTypeVisible)
    getNonContiguousColumn Data, rng
    
    'Find the unique values
    Dim j As Long
    For j = 0 To UBound(Data)
        For r = 1 To UBound(Data(j))
            dict(Data(j)(r, 1)) = Empty
        Next r
    Next j

    '...

End Sub

...backed up by the following:

Sub getNonContiguousColumn(ByRef Data As Variant, _
                           NonContiguousColumnRange As Range, _
                           Optional FirstIndex As Long = 0)
    
    Dim j As Long
    j = FirstIndex - 1
    ReDim Data(FirstIndex To NonContiguousColumnRange.Areas.Count + j)
    
    Dim ar As Range
    Dim OneCell As Variant
    ReDim OneCell(1 To 1, 1 To 1)
    
    For Each ar In NonContiguousColumnRange.Areas
        j = j + 1
        If ar.Cells.Count > 1 Then
            Data(j) = ar.Value
        Else
            OneCell(1, 1) = ar.Value
            Data(j) = OneCell
        End If
    Next ar
    
End Sub

Test the previous Sub with something like the following:

Sub testGetNCC()
    
    Const rngAddr As String = "A2:A20"
    
    Dim Data As Variant
    Dim rng As Range
    Set rng = Range(rngAddr).SpecialCells(xlCellTypeVisible)
    
    getNonContiguousColumn Data, rng

    Dim j As Long, i As Long
    
    For j = 0 To UBound(Data)
        For i = 1 To UBound(Data(j))
            Debug.Print Data(j)(i, 1)
        Next i
    Next j

End Sub

Upvotes: 2

FaneDuru
FaneDuru

Reputation: 42236

Please, replace this piece of code:

data = shtData.Range("P2:P" & lastrow).SpecialCells(xlCellTypeVisible)
    
    'Find the unique values
    For r = 1 To UBound(data)
        dict(data(r, 1)) = Empty
    Next

with the next one:

    Dim rng As Range, C As Range
    Set rng = shtData.Range("P2:P" & lastRow).SpecialCells(xlCellTypeVisible)
    
    'Find the unique values
    For Each C In rng.cells
        dict(C.Value) = Empty
    Next

Your initial code iterates between the first area range cells.

The second one will iterate between all visible range cells...

Upvotes: 1

Related Questions