VBA函数用唯一的拆分条目填充列

Question

I am in need of help creating a very specific VBA function. I need a function that will both split a cell's values and populate another column with unique values.

I am currently using =IFERROR(INDEX(List,MATCH(0,INDEX(COUNTIF($A$1:A2,List),0,0),0)),"") in order to get unique values out of one column to another. Unfortunately, some of these values will be concatenated with a "," but still need to be unique.

Unfortunately, my knowledge of VBA is far from extensive. Does anyone have any suggestions?

Answer 1

Say we have data like:

In column A . Running this macro will extract uniques and put then in column B :

Sub dural()
    Dim c As Collection, K As Long
    Set c = New Collection
    K = 1
    On Error Resume Next
    For Each r In Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row)
        ary = Split(r.Text, ",")
        For Each a In ary
            c.Add a, CStr(a)
            If Err.Number = 0 Then
                Cells(K, "B").Value = a
            K = K + 1
            Else
                Err.Number = 0
            End If
        Next a
    Next r
    On Error GoTo 0
End Sub

EDIT#1:

Here is the same logic in UDF form:

Public Function UniKues(rIn As Range)
    Dim c As Collection, K As Long
    Set c = New Collection
    K = 1
    On Error Resume Next
    For Each r In rIn
        ary = Split(r.Text, ",")
        For Each a In ary
            c.Add a, CStr(a)
        Next a
    Next r

    ReDim bry(1 To c.Count, 1 To 1)
    For i = 1 To c.Count
        bry(i, 1) = c.Item(i)
    Next i
    UniKues = bry
    On Error GoTo 0

End Function

Just hi-light a section of column B and enter the UDF in Array form

EDIT#2

Here is the UDF with chris neilsen's suggestions:

Public Function UniKues(rIn As Range)

    Dim c As Collection, K As Long, MM As Long
    Dim CC As Long
    Set c = New Collection
    K = 1
    On Error Resume Next
    For Each r In rIn
        ary = Split(r.Text, ",")
        For Each a In ary
            c.Add a, CStr(a)
        Next a
    Next r
    MM = Application.Caller.Rows.Count
    CC = c.Count
    dimn = Application.WorksheetFunction.Max(MM, CC)
    ReDim bry(1 To dimn, 1 To 1)
    For i = 1 To CC
        bry(i, 1) = c.Item(i)
    Next i
    If MM > CC Then
        For i = CC + 1 To MM
            bry(i, 1) = ""
        Next i
    End If
    UniKues = bry
    On Error GoTo 0

End Function