Extract unique value from range a1:a500 with one condition

How about

Sub getUnique()

   Dim Cl As Range
   
   With CreateObject("scripting.dictionary")
      For Each Cl In Range("A1:A500")
         If Cl.Offset(, 2) = "4 OL BC" And Not .exists(Cl.Value) Then .Add Cl.Value, Nothing
      Next Cl
      Range("B1").Resize(.Count).Value = Application.Transpose(.keys)
   End With
End Sub

Originally Posted by Fluff13

How about

Sub getUnique()

   Dim Cl As Range
   
   With CreateObject("scripting.dictionary")
      For Each Cl In Range("A1:A500")
         If Cl.Offset(, 2) = "4 OL BC" And Not .exists(Cl.Value) Then .Add Cl.Value, Nothing
      Next Cl
      Range("B1").Resize(.Count).Value = Application.Transpose(.keys)
   End With
End Sub

Thank you for reply
its giving an error
Runtime error 13
Type mismatch

Which line is highlighted when you get the error?

If it's on this line

 Range("B1").Resize(.Count).Value = Application.Transpose(.keys)

Then try

Sub getUnique()
   
   Dim Cl As Range
   Dim Ky As Variant
   
   With CreateObject("scripting.dictionary")
      For Each Cl In Range("A1:A500")
         If Cl.Offset(, 2) = "4 OL BC" And Not .exists(Cl.Value) Then .Add Cl.Value, Nothing
      Next Cl
      For Each Ky In .keys
         Range("B" & Rows.Count).End(xlUp).Offset(1).Value = Ky
      Next Ky
   End With
End Sub

Originally Posted by HaroonSid

I have to choose criteria from range a2:a500 and the extract unique values from range(b2:b500)

i think i cant use negative value with resize property
then what i do

No, Resize property must have positive value.

And I don't think I understand what you are trying to do.
What is this question related to your original question?

Originally Posted by HaroonSid

Hi,
I want to extract unique values from range a1:a500 in range b1 but only if range.Offset(0,102)= "4 OL BC"

Sub test()
    Dim a, i As Long
    Columns("b").ClearContents
    a = [a1:a500].Resize(, 103).Value
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For i = 1 To UBound(a, 1)
            If a(i, UBound(a, 2)) = "4 OL BC" Then .Item(a(i, 1)) = Empty
        Next
        If .Count Then
            [b1].Resize(.Count).Value = Application.Transpose(.keys)
        Else
            MsgBox "No ""4 OL BC"" in Column " & Replace([a1].Offset(, 102).Address(0, 0), 1, "")
        End If
    End With
End Sub

Originally Posted by HaroonSid

And thank you you2
its more fast then others

Why don't you use faster one? (I don't believe it though)

Sub test()
Dim r as range,rg as range,a(),i as long
Set rg =[a1:a500]
Redim a(1 to rg.rows.count,1 to 1)
With createObject("scripting.dictionary")
 For each r in rg
  If r(1,103).value ="4 OL BC" then
     If not.exists(r.value) then
         i = i + 1
        .item(r.value) = i
        a(i,1) = r.value
    End if
  End if
 Next r
End with
[B1].Resize(i,1).value = a
End sub

Then something like

Sub test()
    Dim a, i As Long
    a = [a1:b500].Value
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For i = 1 To UBound(a, 1)
            If a(i, 1) = "4 OL BC" Then .Item(a(i, 2)) = Empty
        Next
        If .Count Then
            [q2].Resize(.Count).Value = Application.Transpose(.keys)
        Else
            MsgBox "No ""4 OL BC"" in Column A"
        End If
    End With
End Sub