Уникальное количество ячеек, разделенных запятыми

Question

Скажите, у меня есть ячейка, содержащая следующее: [A, B, C, B, A].Как я смогу получить уникальные значения вместе с их количеством?ех.A = 2, B = 2, C = 1

Answer 1

Выберите ячейку, содержащую данные, и запустите этот короткий макрос VBA:

Sub WhatsInIt()
    Dim s As String, arr
    Dim c As Collection, a
    Dim i As Long, msg As String

    Set c = New Collection
    msg = ""
    s = ActiveCell.Text
    s = Mid(s, 2, Len(s) - 2)

    arr = Split(s, ",")
    On Error Resume Next
        For Each a In arr
            c.Add a, CStr(a)
        Next a
    On Error GoTo 0

    For i = 1 To c.Count
        msg = msg & vbCrLf & c.Item(i) & vbTab & aCount(c.Item(i), arr)
    Next i

    MsgBox msg
End Sub


Public Function aCount(st As String, ary As Variant) As Long
    Dim ar
    aCount = 0
    For Each ar In ary
        If ar = st Then aCount = aCount + 1
    Next ar
End Function

РЕДАКТИРОВАТЬ # 1:

Эта версия помещает результат в ячейки:

Sub WhatsInIt2()
    Dim s As String, arr
    Dim c As Collection, a
    Dim i As Long, msg As String

    Set c = New Collection
    msg = ""
    s = ActiveCell.Text
    s = Mid(s, 2, Len(s) - 2)

    arr = Split(s, ",")
    On Error Resume Next
        For Each a In arr
            c.Add a, CStr(a)
        Next a
    On Error GoTo 0

    With ActiveCell
        For i = 1 To c.Count
            .Offset(i - 1, 1).Value = c.Item(i)
            .Offset(i - 1, 2).Value = aCount(c.Item(i), arr)
        Next i
    End With

End Sub

Public Function aCount(st As String, ary As Variant) As Long
    Dim ar
    aCount = 0
    For Each ar In ary
        If ar = st Then aCount = aCount + 1
    Next ar
End Function

(функция aCount () не изменяется)