Create unique items in valiadtion list

[YasserKhalil]

Hello everyone
I have a validation list of three items (A,B,C)
these values are in column A ..
In E4 I have validation list of the three values (A,B,C)
The required in F4 to create validation list of unique items for specific item
As an example if I select A in cell E4 , i expect to have a list of these values(20,5,9,19) only
Hope it is clear

[berlan]

Hi buddy,

try this worksheet event (put in the Sheet1 module):

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim a, i As Long, d As Object
    If Target.Cells.Count > 1 Then Exit Sub
    
    With Range("E4")    'dropdown cell
        If Not Intersect(Target, .Cells(1)) Is Nothing Then
        
            a = Range("A2", Range("A" & Rows.Count).End(xlUp)).Resize(, 2).Value
            Set d = CreateObject("Scripting.Dictionary")
            
            For i = 1 To UBound(a, 1)
                If a(i, 1) = .Value Then d.Item(a(i, 2)) = Empty
            Next
            
            If d.Count Then
                With .Offset(, 1).Validation    'change validation on the cell next to the dropdown
                    .Delete: .Add 3, , , Join(d.keys, ",")
                End With
            End If
            
            Set d = Nothing
            
        End If
    End With
    
End Sub

Hope this helps,

berlan

[NeedForExcel]

On the Worksheet Module -

Private Sub Worksheet_Change(ByVal Target As Range)
    
    If Not Intersect(Target, Range("E4")) Is Nothing Then
        Unique
    End If
    
End Sub

On a regular code module -

Sub Unique()
    Dim r, s, InputVal As String, Counter As Integer, i As Integer, Str As String
    r = Sheet1.Range("A2:B" & Cells(Rows.Count, 1).End(xlUp).Row)
    ReDim s(0)
    
    InputVal = Sheet1.Range("E4").Value2
    
    For Counter = LBound(r, 1) To UBound(r, 1)
        
        If r(Counter, 1) = InputVal Then
            i = i + 1
            ReDim Preserve s(i - 1)
            s(i - 1) = r(Counter, 2)
        End If
        
    Next Counter
            
    For Counter = LBound(s) To UBound(s)
        Str = Str & s(Counter) & ","
    Next Counter
    
    With Sheet1.Range("F4").Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=Left(Str, Len(Str) - 1)
        .IgnoreBlank = True
        .InCellDropdown = True
    End With
    
End Sub

See the file attached for reference.

[NeedForExcel]

After seeing Berlan's code, I just realized I missed out on the "Unique" Part..

Sorry!

[bulina2k]

another way of doing it:

Private Sub Worksheet_Change(ByVal Target As Range)
    
    Dim uniq, Rng As Range
    
    If Target.Address <> "$E$4" Then Exit Sub
    
    Range("K3:L" & Range("L" & Rows.Count).End(xlUp).Row).Clear
    Range("F4").ClearContents
    
    Range("A1:B" & Range("A" & Rows.Count).End(xlUp).Row).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _
    "E3:F4"), CopyToRange:=Range("K3:L3"), Unique:=True
    Set Rng = Range("L4:L" & Range("L" & Rows.Count).End(xlUp).Row)
    ActiveWorkbook.Names.Add Name:="uniq", RefersTo:=Rng
    
    With Range("F4").Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
        Operator:=xlBetween, Formula1:="=uniq"
        
    End With
End Sub

[YasserKhalil]

Thanks a lot everyone for these great solutions
@NeedForExcel it is ok but for it brings all the values .. I refer in my request to unique values
@bulina2k very good solution but its problem it depends on columns inside the sheet and creating named ranges ..
@ berlan yout code is perfect for me frankly ..

Is it possible to create a dynamic list (unique results) by formulas ? just for curious
Thank you very much for you great help

[YasserKhalil]

@Mr Berlan
How to deal with the following attachment
I need to create a nother validation list based on F4 in cell G4
Sorry for bothering you again

[berlan]

Thanks again for kind feedback. Taking a third validation list into account, this should do the trick:

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim a, i As Long

    If Target.Cells.Count > 1 Then Exit Sub
    If Target.Value = vbNullString Then Exit Sub
    If Intersect(Range("E4:F4"), Target) Is Nothing Then Exit Sub

    a = Range("A2", Range("A" & Rows.Count).End(xlUp)).Resize(, 3).Value

    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(a, 1)
            If Target.Address = "$E$4" Then
                If a(i, 1) = Target.Value Then .Item(a(i, 2)) = Empty
            Else
                If a(i, 1) = Target(, 0).Value And a(i, 2) = Target.Value Then .Item(a(i, 3)) = Empty
            End If
        Next
        If .Count Then
            Target.Resize(, 2).Offset(, 1).Validation.Delete
            Target.Offset(, 1).Validation.Add 3, , , Join(.keys, ",")
            Application.EnableEvents = False
            Target.Offset(, 1).ClearContents
            Application.EnableEvents = True
        End If
    End With

End Sub

Cheers

[YasserKhalil]

You are awesome ..Thank you very much for this wonderful solution