Excel 2010: VBA convert custom function code to a module with macro shortcut

Question

Info: Excel 2010
Notes: The code works exactly how I need, I am now wanting to automate it a little

I recently came across this code, it's for a custom function, however I can not create a button for it (like a macro), I would like to convert some of this code, however I don't know what to do or how to go about it. I want to have a shortcut/button on my ribbon.

https://stackoverflow.com/a/17337453/2337102

Function listUnique(rng As Range) As Variant
Dim row As Range
Dim elements() As String
Dim elementSize As Integer
Dim newElement As Boolean
Dim i As Integer
Dim distance As Integer
Dim result As String

elementSize = 0
newElement = True

For Each row In rng.Rows
    If row.Value <> "" Then
        newElement = True
        For i = 1 To elementSize Step 1
            If elements(i - 1) = row.Value Then
                newElement = False
            End If
        Next i
        If newElement Then
            elementSize = elementSize + 1
            ReDim Preserve elements(elementSize - 1)
            elements(elementSize - 1) = row.Value
        End If
    End If
Next

distance = Range(Application.Caller.Address).row - rng.row

If distance < elementSize Then
    result = elements(distance)
    listUnique = result
Else
    listUnique = ""
End If
End Function  

Results with the ability to:

Just enter =listUnique(range) to a cell. The only parameter is range that is an ordinary Excel range. For example: A$1:A$28 or H$8:H$30.

I would like the following: Create a macro button with an a popup Inputbox to ask for a range.

Usage:

1) I am in the cell where I require the list to begin (BA9)
2) I click the custom module/macro button & popup box asks me the range (G$8:G$10000)
3) The result then autofills in column (BA)

Lastly, can the code be amended so that the restriction of "The first cell where you call the function must be in the same row where the range starts." be removed so that I can use a reference from another sheet within the same workbook.

I apologise if I should have gone direct to the coder, the thread that it was in is old & I thought given the amount of change I'm asking for it may be better suited in its own question.

Thank you in advance.

Answer 1

First approach: (you can use RemoveDuplicates method instead function listUnique)

Just assign this Sub to your custom button:

Sub testRemoveDuplicates()
    Dim targetRange As Range
    Dim actCell As Range
    Dim res As Variant

    Set actCell = ActiveCell

    On Error Resume Next
    Set targetRange = Application.InputBox("Please highlight the cell for TARGET", Type:=8)
    On Error GoTo 0

    If targetRange Is Nothing Then
       MsgBox "User has pressed cancel"
       Exit Sub
    End If

    targetRange.Copy
    actCell.PasteSpecial xlPasteValues
    actCell.RemoveDuplicates Columns:=1, Header:=xlNo

    Application.CutCopyMode = False
End Sub

---

Second approach: (if you'd like to use function listUnique)

Here is another listUnique function. You can get list of unique elements usign Dictionary object (it is better suited for your purposes):

Function listUnique(rng As Range) As Variant
    Dim row As Range
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")

    On Error Resume Next

    For Each row In rng.Rows
        If row.Value <> "" Then
            dict.Add row.Value, row.Value
        End If
    Next

    Dim res As Variant
    ReDim res(1 To dict.Count)

    res = dict.Items

    Set dict = Nothing
    listUnique = Application.Transpose(res)
End Function

then you can call it using following Sub (you can assign it to custom button):

Sub test()
    Dim targetRange As Range
    Dim actCell As Range
    Dim res As Variant

    Set actCell = ActiveCell

    On Error Resume Next
    Set targetRange = Application.InputBox("Please highlight the cell for TARGET", Type:=8)
    On Error GoTo 0

    If targetRange Is Nothing Then
       MsgBox "User has pressed cancel"
       Exit Sub
    End If

    res = listUnique(targetRange)

    actCell.Resize(UBound(res)) = res
End Sub

Note: if you're going to call this listUnique function direct from worksheet (as UDF function), you should select destination range (in example D10:D20), with selected range enter formula =listUnique(A1:A10) in formula bar, and press CTRL+SHIFT+ENTER to evaluate it.