Auto Unique List

[r_know]

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

[Excel Fox]

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

[Excel Fox]

Try something like this



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

[Admin]

Hi

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


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

[r_know]

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!

[Excel Fox]

Crossposted here (http://vbaexpress.com/forum/showthread.php?t=42960)


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.

[r_know]

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.

[bakerman]

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.

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

[r_know]

Thanks A Lot

I was away for business trip and just back.

I checked and worked perfect.