Excel VBA:统计ID号的唯一类别数

我在第一列有身份证号码，在第二列有技术类别

数据样本如下所示

---

IDTech-categorySA091H4SA091H3SA091H2EP82K2EP82K2EP82H4EP93T0EP93T0TB99Y2

类似的内容。不确定这是不是最好的方法，只是玩了一场

Sub uniques()

Dim dicCodes As New Scripting.Dictionary
Dim dicContents As Scripting.Dictionary
Dim rngCodes As Range
Dim rngInspect As Range

Set rngCodes = Range("a1:a10")

For Each rngInspect In rngCodes.Cells

    If dicCodes.Exists(rngInspect.Value) Then

        Set dicContents = dicCodes(rngInspect.Value)
        If dicContents.Exists(rngInspect.Offset(0, 1).Value) Then
            dicContents(rngInspect.Offset(0, 1).Value) = _
                dicContents(rngInspect.Offset(0, 1).Value) + 1
        Else
            dicContents.Add rngInspect.Offset(0, 1).Value, 1
        End If

    Else

        Set dicContents = New Scripting.Dictionary
        dicContents.Add rngInspect.Offset(0, 1).Value, 1
        dicCodes.Add rngInspect.Value, dicContents

    End If

Next rngInspect

Dim lngOutput As Long
Dim lngOutputInner As Long

For lngOutput = 0 To dicCodes.Count - 1

    For lngOutputInner = 0 To dicCodes.Items()(lngOutput).Count - 1

        Debug.Print dicCodes.Keys()(lngOutput), _
                    dicCodes.Items()(lngOutput).Keys()(lngOutputInner), _
                    dicCodes.Items()(lngOutput).Items()(lngOutputInner)

    Next lngOutputInner

Next lngOutput

End Sub

---

像这样的。不确定这是不是最好的方法，只是玩了一场

Sub uniques()

Dim dicCodes As New Scripting.Dictionary
Dim dicContents As Scripting.Dictionary
Dim rngCodes As Range
Dim rngInspect As Range

Set rngCodes = Range("a1:a10")

For Each rngInspect In rngCodes.Cells

    If dicCodes.Exists(rngInspect.Value) Then

        Set dicContents = dicCodes(rngInspect.Value)
        If dicContents.Exists(rngInspect.Offset(0, 1).Value) Then
            dicContents(rngInspect.Offset(0, 1).Value) = _
                dicContents(rngInspect.Offset(0, 1).Value) + 1
        Else
            dicContents.Add rngInspect.Offset(0, 1).Value, 1
        End If

    Else

        Set dicContents = New Scripting.Dictionary
        dicContents.Add rngInspect.Offset(0, 1).Value, 1
        dicCodes.Add rngInspect.Value, dicContents

    End If

Next rngInspect

Dim lngOutput As Long
Dim lngOutputInner As Long

For lngOutput = 0 To dicCodes.Count - 1

    For lngOutputInner = 0 To dicCodes.Items()(lngOutput).Count - 1

        Debug.Print dicCodes.Keys()(lngOutput), _
                    dicCodes.Items()(lngOutput).Keys()(lngOutputInner), _
                    dicCodes.Items()(lngOutput).Items()(lngOutputInner)

    Next lngOutputInner

Next lngOutput

End Sub

---

使用一本词典。在读取的值旁边写入结果

Option Explicit
Public Sub testing()
    Dim arr(), i As Long, dict
    Set dict = CreateObject("Scripting.Dictionary")

    With ActiveSheet
        arr() = .Range("A2:B10").Value
        For i = LBound(arr, 1) To UBound(arr, 1)
            If Not dict.Exists(arr(i, 1)) Then
                dict.Add arr(i, 1), CreateObject("Scripting.Dictionary")
                dict(arr(i, 1)).Add arr(i, 2), 1
             Else
                If Not dict(arr(i, 1)).Exists(arr(i, 2)) Then
                    dict(arr(i, 1)).Add arr(i, 2), 1
                Else
                    dict(arr(i, 1))(arr(i, 2)) = dict(arr(i, 1))(arr(i, 2)) + 1
                End If
            End If
        Next i
        Dim key As Variant
        i = 1
        For Each key In dict.keys
            i = i + 1
            .Cells(i, 3) = key
            .Cells(i, 4) = dict(key).Count
        Next key
    End With
End Sub

---

使用一本词典。在读取的值旁边写入结果

Option Explicit
Public Sub testing()
    Dim arr(), i As Long, dict
    Set dict = CreateObject("Scripting.Dictionary")

    With ActiveSheet
        arr() = .Range("A2:B10").Value
        For i = LBound(arr, 1) To UBound(arr, 1)
            If Not dict.Exists(arr(i, 1)) Then
                dict.Add arr(i, 1), CreateObject("Scripting.Dictionary")
                dict(arr(i, 1)).Add arr(i, 2), 1
             Else
                If Not dict(arr(i, 1)).Exists(arr(i, 2)) Then
                    dict(arr(i, 1)).Add arr(i, 2), 1
                Else
                    dict(arr(i, 1))(arr(i, 2)) = dict(arr(i, 1))(arr(i, 2)) + 1
                End If
            End If
        Next i
        Dim key As Variant
        i = 1
        For Each key In dict.keys
            i = i + 1
            .Cells(i, 3) = key
            .Cells(i, 4) = dict(key).Count
        Next key
    End With
End Sub

---

改用字典。我来看看=COUNTIF应该做你想做的事吗？@harassedad它是在计算唯一的相邻数据，而不是发生率。改用字典。我来看看=COUNTIF应该做你想做的事吗？@harassedad它在计算唯一的相邻数据，而不是发生的情况。好的解决方案：o）好的解决方案：o）