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:

Capture.jpg

[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/Fo...s?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 , 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