Creating list of Unique values in offset cells

[Mack 10]

I haven't coded in VBA for ages and I'm really rusty. I have code that goes through and creates a collection of unique cell values from a given range.

I want that list to then be entered into a column under a reference to another cell for other look ups to use. I just can't seem to get it to work.

The collection is being made no probs.
Clearing the cells that the unique list to be placed into is not.
Placing the new values is also not working.

Here's the code;


Function UNIQUEList2(InputRange As Range, Output As Range) As Variant


Dim cl As Range
Dim cUnique As Collection
Dim cValue As Variant
Dim count As Integer
Dim delRange As Range
Set cUnique = New Collection

For Each cl In InputRange.Cells
If Len(cl.Value) > 0 Then
cUnique.Add cl.Value, CStr(cl.Value)
End If
Next cl

Set delRange = Range(Output, Output.Offset(InputRange.Rows.count, 1))
'MsgBox delRange.Address
'^ outputs "$AB$3:$AB2501" which is the range I want deleted.
delRange.ClearContents

For count = 0 To cUnique.count
Output.Offset(count, 1).Value = cUnique(count)
'^Doesn't work at all, function crashes
Next count



End Function


Any help is greatly appreciated,

Thanks,

Haydan

[pike]

Hi Mack 10,
maybe this will help
How are you calling/using the function?


Option Explicit
Sub test()
'Function UNIQUEList2(InputRange As Range, Output As Range) As Variant
Dim cl As Range
Dim cUnique As Collection
Dim cValue As Variant
Dim count As Integer
Dim delRange As Range
Dim InputRange
Dim Output
Set cUnique = New Collection
Set InputRange = Range("B1:B20")
Set Output = Range("K1")
For Each cl In InputRange '.Cells
If Len(cl) > 0 Then
On Error Resume Next
cUnique.Add cl, CStr(cl)
End If
On Error GoTo 0
Next cl
Set delRange = Range(Output, Output.Offset(InputRange.Rows.count, 1))
'^ outputs "$AB$3:$AB2501" which is the range I want deleted.
delRange.ClearContents
For count = 1 To cUnique.count
Output.Offset(count, 1).Value = cUnique(count)
Next count
Set InputRange = Nothing
Set Output = Nothing
End Sub
'End Function

[Mack 10]

I'm wanting to use it as a function so that the lists updated with data input.

So have a cell with =UNIQUEList2($AB$3:$AB2501, A1) somewhere that will create one unique list, =UNIQUEList2($AD$3:$AD1251, B1) on another sheet.

Will give it a try, is there some reason I can't do this from within a function?

Thanks,

Haydan

[GTO]

The collection is being made no probs.
Clearing the cells that the unique list to be placed into is not.
Placing the new values is also not working.



Greetings Haydan,

I may be mis-reading your post, but just in case... How are you calling the function? (Show us the code that calls it)

Mark

[Mack 10]

So this works (note I added .value2 to Output.Offset(count - 1, 0).Value = cUnique(count).Value2 to get it to work);


Sub test()
'Function UNIQUEList2(InputRange As Range, Output As Range) As Variant
Dim cl As Range
Dim cUnique As Collection
Dim cValue As Variant
Dim count As Integer
Dim delRange As Range
Dim InputRange
Dim Output
Set cUnique = New Collection
Set InputRange = Range("S3:S2501")
Set Output = Range("V3")
Application.Calculation = xlCalculationManual
For Each cl In InputRange '.Cells
If Len(cl) > 0 Then
On Error Resume Next
cUnique.Add cl, CStr(cl)
End If
On Error GoTo 0
Next cl
Set delRange = Range(Output, Output.Offset(InputRange.Rows.count, 1))
'^ outputs "$AB$3:$AB2501" which is the range I want deleted.
delRange.ClearContents

For count = 1 To cUnique.count
Output.Offset(count - 1, 0).Value = cUnique(count).Value2
Next count
Application.Calculation = xlCalculationAutomatic
Set InputRange = Nothing
Set Output = Nothing
End Sub


This doesn't (Same as a function pulling range from formula on sheet):



Function UNIQUEListFunc(InputRange As Range, Output As Range) As Variant


Dim cl As Range
Dim cUnique As Collection
Dim cValue As Variant
Dim count As Integer
Dim delRange As Range
Set cUnique = New Collection

Application.Calculation = xlCalculationManual
For Each cl In InputRange '.Cells
If Len(cl) > 0 Then
On Error Resume Next
cUnique.Add cl, CStr(cl)
End If
On Error GoTo 0
Next cl
Set delRange = Range(Output, Output.Offset(InputRange.Rows.count, 1))
'^ outputs "$AB$3:$AB2501" which is the range I want deleted.
delRange.ClearContents

For count = 1 To cUnique.count
Output.Offset(count - 1, 0).Value = cUnique(count).Value2
Next count
Application.Calculation = xlCalculationAutomatic
Set InputRange = Nothing
Set Output = Nothing

End Function

[GTO]

ACK! Never mind, I just read your second post. When calling a function as a User Defined Function (That is, calling it from a cell or cells on a sheet), the function cannot alter other cells. Does that make sense?

Mark

[Mack 10]

I'd like to call it like this:

15237

[Mack 10]

It certainly explains the behavior! :) Can I call the code from a user defined function and pass it the ranges and have it do what I want?

[GTO]

...Can I call the code from a user defined function and pass it the ranges and have it do what I want?

Hi Mack,

As I read your code, it appears to me that you want to copy values, skipping the blank cells. If I have that right, I think we should be able to do that (I didn't really test) but the "output" range must be the range of cells that the UDF is entered (as an array formula). Is that any help?

Mark

[Mack 10]

It's doing a little more than removing blanks - it removes duplicates also.

Problem is that these unique lists end up spanning 50k+ cells from 10 difference columns of samples and it kinda slows it down. If I can run it once per list, and have it only run when that lists inputs change I should be able to make it preform well.

Maybe I'll use a watch on the lists and run the sub when they change, it's not my preferred method as it will mean I have to update the watch cells when ever I want to add/remove pages or modify the length of the lists but if it works it works.

[GTO]

Just a comment: Not well researched, and I find nothing about it so far, but there seems to be a limitation of 65536 cells that can be passed to the UDF. So if you mean 50k cells total, I don't see an issue. On the other hand, I fooled around with a possible UDF and found that it falls over if above 2^16 cells are in the ranges.

I copied values from scowl.dic and plastered them in various columns. With the following UDF:


Public Function UNIQUEList2(ParamArray InputRanges() As Variant) As Variant
Dim IndividualRange As Variant
Dim IndRange As Range
Dim Cell As Range
Dim Index As Long
Dim CellCount As Long
Dim Output As Variant
Dim AlternateOutput As Variant
Dim DIC As Object ' Scripting.Dictionary

On Error GoTo errCheck

Set DIC = CreateObject("Scripting.Dictionary")

For Index = 0 To UBound(InputRanges)
If Not TypeName(InputRanges(Index)) = "Range" Then
Exit Function
End If
Next

For Each IndividualRange In InputRanges
Set IndRange = IndividualRange
CellCount = CellCount + IndRange.Cells.Count
For Each Cell In IndRange.Cells
DIC.Item(Cell.Value) = Empty
Next
Next IndividualRange

On Error Resume Next
DIC.Remove (vbNullString)
'On Error GoTo 0
On Error GoTo errCheck

Output = DIC.Keys
ReDim Preserve Output(0 To (CellCount - 1))
For Index = DIC.Count To CellCount - 1
Output(Index) = vbNullString
Next

If Not CellCount > 65536 Then
Output = Application.Transpose(Output)

UNIQUEList2 = Output
Else
ReDim AlternateOutput(1 To CellCount, 1 To 1)
For Index = 1 To UBound(Output, 1) + 1
AlternateOutput(Index, 1) = Output(Index - 1)
Next

UNIQUEList2 = AlternateOutput
End If
Exit Function
errCheck:
Stop
Resume Next
End Function

...array entered as: =UNIQUEList2(A2:A50001,C2:C15537) <---This works fine.

But if array entered as: =UNIQUEList2(A2:A50001,C2:C15538) <---This returns the #VALUE! error.

Of course it runs/returns fine in vba:


Sub test()
Dim a
a = UNIQUEList2(Range("A2:A50001"), Range("C2:C15538"))
Stop
End Sub

Hopefully someone will comment.

Mark

PS - I did find this, just in case the info is of help. https://support.microsoft.com/en-us/kb/170787

[Aflatoon]

Charles Williams mentions the inability to return more than 65536 rows from a UDF here: https://social.msdn.microsoft.com/Forums/en-US/c45d37f1-a5f1-4cf4-938d-69d294d8e447/limitations-on-arrays?forum=isvvba

You can work around it by returning multiple columns. You should also probably resize the array returned to exclude empty items:


Public Function UNIQUEList2(ParamArray InputRanges() As Variant) As Variant Dim IndividualRange As Variant
Dim IndRange As Range
Dim Cell As Range
Dim Index As Long
Dim CellCount As Long
Dim Output As Variant
Dim AlternateOutput As Variant
Dim DIC As Object ' Scripting.Dictionary
Dim lCol As Long
Dim lRow As Long


On Error GoTo errCheck


Set DIC = CreateObject("Scripting.Dictionary")


For Index = 0 To UBound(InputRanges)
If Not TypeName(InputRanges(Index)) = "Range" Then
Exit Function
End If
Next


For Each IndividualRange In InputRanges
Set IndRange = IndividualRange
For Each Cell In IndRange.Cells
If Len(Cell.Value2) <> 0 Then
DIC.Item(Cell.Value) = Empty
CellCount = CellCount + 1
End If
Next
Next IndividualRange


On Error GoTo errCheck


Output = DIC.Keys
ReDim Preserve Output(0 To (CellCount - 1))
For Index = DIC.Count To CellCount - 1
Output(Index) = vbNullString
Next


If Not CellCount > 65536 Then
Output = Application.Transpose(Output)


UNIQUEList2 = Output
Else
ReDim AlternateOutput(1 To 65536, 1 To CellCount \ 65536 + 1)
lCol = 1
lRow = 1
For Index = 1 To UBound(Output, 1) + 1
AlternateOutput(lRow, lCol) = Output(Index - 1)
If Index Mod 65536 = 0 Then
lRow = 1
lCol = lCol + 1
Else
lRow = lRow + 1
End If
Next


UNIQUEList2 = AlternateOutput
End If
Exit Function
errCheck:
Stop
Resume Next
End Function

[snb]

why don't you


sub M_snb()
sheet1.range("$AB$3:$AB2501").advancedfilter 2,,sheet2.cells(1),true
End Sub

[GTO]

Thank you for the info Rory :bow:, at least I wasn't just doing something daffy. Off for the next couple of days, but will try yours.

Hope Michigan is nice!

Mark