Auto Unique List

Dear All,

I have a list in Sheet 1 in H column and I want unique list in Sheet 2, A column.

But list calculates automatically are a conditions, as Sheet 2 are very hidden.

Please advise.

Means
Sheet 1 visible!
Sheet 2 very hidden!

Required unique list in Sheet 2....

Regards,

RL

Does it start from first row? Does it have a header column?

Try something like this

Code:

---

Function GetUniqueList(rng As Range, ByRef lng As Long)

    Dim var As Variant
    Dim obj As Object
   
    Set obj = CreateObject("Scripting.Dictionary")
    If rng.Columns.Count = 1 Then
        var = rng
        For lng = LBound(var) To UBound(var)
            If Not obj.Exists(var(lng, 1)) Then
                obj.Add var(lng, 1), var(lng, 1)
            End If
        Next lng
    End If
    lng = obj.Count
    GetUniqueList = Application.Transpose(obj.keys)
   
End Function

Sub Test()
   
    Dim lng As Long
    With Worksheets("Sheet2")
        .Range(.Cells(1), .Cells(.Rows.Count, 1).End(xlUp)).Value = Null
        .Cells(1).Resize(lng).Value = GetUniqueList(Worksheets("Sheet1").Range("H1:H" & Worksheets("Sheet1").Cells(Rows.Count, "H").End(xlUp).Row), lng)
    End With
   
End Sub

---

Hi

or put this code in Sheet1 module. (Right click on Sheet1 tab name > view code > paste the code there)

Code:

---

Dim dic    As Object
Private Sub Worksheet_Change(ByVal Target As Range)
   
    If Target.Column <> 8 Then Exit Sub
   
    Dim i  As Long
    Dim k
   
   
    If dic Is Nothing Then
        Set dic = CreateObject("scripting.dictionary")
            dic.comparemode = 1
    End If
    dic.RemoveAll
    If Not Intersect(Me.UsedRange, Me.Columns(8)) Is Nothing Then
        k = Intersect(Me.UsedRange, Me.Columns(8)).Value2
        If IsArray(k) Then
            For i = 1 To UBound(k, 1)
                If Len(k(i, 1)) Then dic.Item(k(i, 1)) = Empty
            Next
            If dic.Count Then
                With Sheet2
                    .Columns(1).Clear
                    .Cells(2, 1).Resize(dic.Count) = Application.Transpose(dic.keys)
                End With
            End If
        ElseIf Len(k) Then
            Sheet2.Columns(1).Clear: Sheet2.Cells(2, 1) = k
        End If
    End If
                   
End Sub

---

Thanks I try Above!
Wonderful!

But in my original sheet having small changes, can you modified your above code.

Sheet 1 Name:- WDO & Range starts from H6:H1201 for slection of Unique List.
Sheet 2 Name:- MS amd A1 Cell having Cell Name RangeUnique; so I want unique list A2 to further below. Again Sheet 2, MS is very Hidden!

Crossposted here


r_know, Cross-posting is like calling ten cab vendors at the same time, and hoping on the first one that comes along. There are clear rules about cross-posting. From a developers(volunteers) point-of-view, posting the same query across multiple forums is not appreciated, UNLESS you mention that in the respective forums explicitly, which will then allow volunteers to know whether a solution is already provided.

We hope that you will comply to the said guidelines and not invite infractions.

True , I will keep in mind and will follow the forum rules in future. Actually, I did not get the answer which I am looking for, therefore posted here. Anyway, I accept and apology to forum and will not do again.

But is it possible me a get answer to above, reason this code work great and I have required the modifications.

The answer was already given to you a few posts ago.
You could have figured out the minor changes to the code yourself, they weren't that difficult.
This works fine for me.

Code:

---

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim i As Long, dic As Object, k
   
    If Target.Column <> 8 Then Exit Sub
   
    If dic Is Nothing Then
        Set dic = CreateObject("scripting.dictionary")
            dic.comparemode = 1
    End If
   
    dic.RemoveAll
 
    If Not Intersect(Me.UsedRange, Me.Range("H6:H1201")) Is Nothing Then
        k = Intersect(Me.UsedRange, Me.Range("H6:H1201")).Value2
        If IsArray(k) Then
            For i = 1 To UBound(k, 1)
                If Len(k(i, 1)) Then dic.Item(k(i, 1)) = Empty
            Next
            If dic.Count Then
                With Sheets("MS")
                    .Range(.Range("A2"), .Range("A" & Rows.Count).End(xlUp)).Clear
                    .Cells(2, 1).Resize(dic.Count) = Application.Transpose(dic.keys)
                End With
            End If
        ElseIf Len(k) Then
            With Sheets("MS")
                .Range(.Range("A2"), .Range("A" & Rows.Count).End(xlUp)).Clear
                .Cells(2, 1) = k
            End With
        End If
    End If
End Sub

---

Thanks A Lot

I was away for business trip and just back.

I checked and worked perfect.