Get unique list with filtered range of another column

user_12378698 0
Viewed 101

I need to extract the unique values in column B, for every unique value in column A. I have a code from a post but it lists out the entire column's unique values. What I want are only those unique values that are associated with the filter criteria I have provided.

I need to move these unique values to an array and use it for another sheet calculation. The code I have so far is below.

Sub test()
    Dim TestRg As Excel.Range
    Dim Array1(200) As Variant
    Dim i, j As Integer
    i = 1
    
    Set TestRg = Range("L1:L181")
    TestRg.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
        ActiveCell, Unique:=True
    For Each C In TestRg.SpecialCells(xlCellTypeVisible)
    If Not (C) Is Nothing Then
        Array1(i) = C.Value
        i = i + 1
    End If
    Next C
    j = i - 1
    i = 1

    
    For i = 1 To j
    Debug.Print Array1(i)
    Next
End Sub

Pl help.

vba excel
1 Answers

This macro will capture all distinct values of all visible cells in Column A of your activesheet and set the values in Column B. If rows are hidden in Column B, it may not display as you intend.

Sub findtheVisibleUniqueValues()
Dim sRange As Range, aCell As Range, i As Long
Dim ws As Worksheet
    Set ws = ActiveSheet
    
ReDim zRay(1 To 1, 1 To 1)
i = 1

Set sRange = Intersect(ws.Range("A:A"), ws.UsedRange)

For Each aCell In sRange.Cells
    If aCell.EntireRow.Hidden = True Then
        'skip
    ElseIf Not (checkForMatch(aCell.Value, zRay)) Then
            ReDim Preserve zRay(1 To 1, 1 To i)
            zRay(1, i) = aCell.Value
            i = i + 1
    End If

Next aCell

'Your array is complete.
'This will insert to Column B (note if rows are hidden, it may not display correctly)

ws.Range("B1").Resize(UBound(zRay, 2), 1).Value = Application.WorksheetFunction.Transpose(zRay)

End Sub



Private Function checkForMatch(theValue As Variant, theArray()) As Boolean
Dim g As Long, j As Long

For j = LBound(theArray) To UBound(theArray)
    For g = LBound(theArray, 2) To UBound(theArray, 2)
        If theValue = theArray(j, g) Then
            checkForMatch = True
            Exit Function
        End If
    Next g
Next j

End Function
user_117323200
Related