Creating A List of Unique Values

[Ark68]

I am using this code (thanks @pboltonchina) to create a list of all the unique values captured from column A in ws_ifm , to column L in ws_modlist starting at L2.
I get no errors, however, I am only getting one value listed, at L2 when there should be dozens in this list. Where have I gone wrong? Perhaps I misunderstood the results of this code?

Sub UniqueList()
' @pboltonchina https://www.mrexcel.com/board/threads/vba-create-unique-list-from-range-of-data.611558/
Dim uniqueArray() As Variant
Dim count As Integer
Dim notUnique As Boolean
Dim lstrow As Long, ml_lstrow As Long
Dim i As Long

ReDim uniqueArray(0) As Variant
uniqueArray(0) = Range("A1")
count = 0
Stop
Dim cl As Range
With ws_ifm
    .Unprotect
    .AutoFilterMode = False
    lstrow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Debug.Print "Last row in FM: " & lstrow
End With

With ws_modlist
    'prepare model list destination
    If .AutoFilterMode Then .AutoFilter = False
    ml_lstrow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    If ml_lstrow > 1 Then .Range("L2:L" & ml_lstrow).ClearContents
  
    For Each cl In .Range("A3:A" & lstrow)
        notUnique = False
        For i = LBound(uniqueArray) To UBound(uniqueArray)
            If (cl.Value = uniqueArray(i)) Then
                notUnique = True
                Exit For
            End If
        Next i
  
        If notUnique = False Then
            count = count + 1
            ReDim Preserve uniqueArray(count) As Variant
            uniqueArray(UBound(uniqueArray)) = cl.Value
        End If
    Next cl
Stop
    For i = LBound(uniqueArray) To UBound(uniqueArray)
        .Range("L2").Offset(i, 0) = uniqueArray(i)
    Next i
End With
End Sub

 

[mumps]

Try:

Sub UniqueList()
    Application.ScreenUpdating = False
    Dim v As Variant, i As Long, dic As Object
    With ws_ifm
        .Unprotect
        v = .Range("A2", .Range("A" & .Rows.count).End(xlUp))
    End With
    Set dic = CreateObject("Scripting.Dictionary")
    For i = LBound(v) To UBound(v)
        If Not dic.exists(v(i, 1)) Then
            dic.Add v(i, 1), Nothing
        End If
    Next i
    ws_modlist.Range("L2").Resize(dic.count) = Application.Transpose(dic.keys)
    Application.ScreenUpdating = True
End Sub

 

[Ark68]

Disregard. I think I may have found the issue ...

For Each cl In .Range("A3:A" & lstrow)

Should be:

For Each cl In ws_ifm.Range("A3:A" & lstrow)

But now that it works, this code eventually crashes. Is 7000+ cells of data too much for this code to compile uniques?[/code]

 

[mumps]

Did you try the macro I suggested in Post #2? Change the range to suit your needs.

 

[Ark68]

Try:

Sub UniqueList()
    Application.ScreenUpdating = False
    Dim v As Variant, i As Long, dic As Object
    With ws_ifm
        .Unprotect
        v = .Range("A2", .Range("A" & .Rows.count).End(xlUp))
    End With
    Set dic = CreateObject("Scripting.Dictionary")
    For i = LBound(v) To UBound(v)
        If Not dic.exists(v(i, 1)) Then
            dic.Add v(i, 1), Nothing
        End If
    Next i
    ws_modlist.Range("L2").Resize(dic.count) = Application.Transpose(dic.keys)
    Application.ScreenUpdating = True
End Sub

This worked far better than my previous attempt Mumps, thank you so much!

 

[mumps]

You are very welcome.