VBA用于使用唯一的拆分条目填充列的功能

时间:2015-02-13 16:49:35

标签: excel vba excel-vba unique

我需要帮助创建一个非常具体的VBA功能。 我需要一个函数来分割单元格的值并用唯一值填充另一列。

我目前正在使用=IFERROR(INDEX(List,MATCH(0,INDEX(COUNTIF($A$1:A2,List),0,0),0)),""),以便从一列到另一列获取唯一值。 不幸的是,其中一些值将与“,”结合,但仍然需要是唯一的。

不幸的是,我对VBA的了解远非广泛。有没有人有任何建议?

1 个答案:

答案 0 :(得分:2)

假设我们有以下数据:

enter image description here

A 栏中。运行此宏将提取唯一身份,然后将其放在 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

enter image description here

修改#1:

以下是 UDF 形式的相同逻辑:

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

enter image description here

只需点亮 B 列的一部分,然后在数组表单中输入 UDF

修改#2

以下是 UDF 以及 chris neilsen的建议:

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