Question

我正在尝试构建一个集合并从该集合中获取唯一值计数但是在构建集合本身时出错。任何人都可以建议我在哪里出错。请分享您的想法。请让我知道如何找出唯一值的COUNT。

Sub trial()

Dim sampleVisualBasicColl As Collection

For i = 2 To 10

    Rng = Range("M" & i).value

    StartsWith = Left(Rng, 3)

    If StartsWith = "Joh" Then

            sampleVisualBasicColl.Add Rng

    Else

    End If

Next

Debug.Print (sampleVisualBasicCol1)

End Sub

Answer 1

您需要创建集合并声明它。

Sub trial()

Dim myCol As Collection

Set myCol= New Collection ' creates the collection

For i = 2 To 10

    Rng = Range("M" & i).value

    StartsWith = Left(Rng, 3)

    If StartsWith = "Joh" Then

            myCol.Add Rng

    Else

    End If

Next

For each x in myCol
   Debug.Print x
Next x

End Sub

Answer 2

使用集合，您只需将Joh添加到集合中，然后计算项目：

'Using a collection
Sub Col_test()

    Dim cCol As Collection
    Dim i As Long

    Set cCol = New Collection

    On Error GoTo Err_Handler

    With ThisWorkbook.Worksheets("Sheet1")
        For i = 2 To 20
            If Left(.Cells(i, 13), 3) = "Joh" Then
                cCol.Add .Cells(i, 13).Value, .Cells(i, 13).Value
            End If
        Next i
    End With

    Debug.Print cCol.Count

    On Error GoTo 0

Exit Sub
Err_Handler:
    Select Case Err.Number
        Case 457 'This key is already associated with an element of this collection
            Err.Clear
            Resume Next
        Case Else
            MsgBox "Error " & Err.Number & vbCr & _
                " (" & Err.Description & ") in procedure Col_test."
            Err.Clear
    End Select

End Sub

如果你想要每个项目的数量（Joh，Ben ......你还有其他什么），那就用一本字典：

'Using a dictionary.
Sub Dic_Test()

    Dim dict As Object
    Dim i As Long
    Dim sValue As String
    Dim key As Variant

    Set dict = CreateObject("Scripting.Dictionary")

    With ThisWorkbook.Worksheets("Sheet1")
        For i = 2 To 20
            If Len(.Cells(i, 13)) >= 3 Then
                sValue = Left(.Cells(i, 13), 3)
                If dict.exists(sValue) Then
                    dict(sValue) = dict(sValue) + 1
                Else
                    dict(sValue) = 1
                End If
            End If
        Next i
    End With

    For Each key In dict.keys
        Debug.Print key & " = " & dict(key)
    Next key

End Sub

注意：我在代码中使用Cells而不是Range。 Cells(2,13)是M2（第13列，第2行）。

我觉得这个链接对词典很有帮助：https://excelmacromastery.com/vba-dictionary/

作为进一步更新（在接听回答之后）并使用您在此处提出的问题列表：Excel VBA - Formula Counting Unique Value error此代码与词典将返回Joh = 4, Ian = 3

'Using a dictionary.
Sub Dic_Test()

    Dim dict As Object
    Dim dictFinal As Object
    Dim i As Long
    Dim sValue As String
    Dim key As Variant
    Dim keyFinal As String

    Set dict = CreateObject("Scripting.Dictionary")
    Set dictFinal = CreateObject("Scripting.Dictionary")

    'Get the unique values from the worksheet.
    With ThisWorkbook.Worksheets("Sheet1")
        For i = 2 To 20
            If Len(.Cells(i, 13)) >= 3 Then
                sValue = .Cells(i, 13).Value
                If dict.exists(sValue) Then
                    dict(sValue) = dict(sValue) + 1
                Else
                    dict(sValue) = 1
                End If
            End If
        Next i
    End With

    'Count the unique values in dict.
    For Each key In dict.keys
        keyFinal = Left(key, 3)
        If dictFinal.exists(keyFinal) Then
            dictFinal(keyFinal) = dictFinal(keyFinal) + 1
        Else
            dictFinal(keyFinal) = 1
        End If
    Next key

    For Each key In dictFinal.keys
        Debug.Print key & " = " & dictFinal(key)
    Next key

End Sub

Answer 3

嘿，这段代码会帮助你，因为它在Listbox中收集了唯一值，

Private Sub UserForm_Initialize（） Dim cUnique As Collection 昏暗的范围昏暗的细胞作为范围 Dim sh As Worksheet Dim vNum As Variant

设置sh = ThisWorkbook.Sheets（“Sheet1”）设置Rng = sh.Range（“A2”，sh.Range（“A2”）。值=“John”。结束（xlDown））

设置cUnique =新集合

On Error Resume Next

对于Rng.Cells中的每个单元格 cUnique.Add Cell.Value，CStr（Cell.Value）下一个细胞

On Error GoTo 0

对于cUnique中的每个vNum Me.ListBox1.AddItem vNum

下一个vNum 结束子

Answer 4

您尚未声明Variable Rng＆amp;我这些是最重要的事情。同时我想建议这个公式，

=总和（如果（频率（如果（Len（B2：B20）> 0，匹配（B2：B20，B2：B20,0），＆＃34;＆＃34;），如果（Len（B2）：B20）＆gt;匹配（B2：B20，B2：B20,0），＆＃34;＆＃34;，））＆gt; 0,1））

其数组公式如此完成，按Ctrl + shift + enter。

你也可以使用这个，

Sub CountUnique（）Dim i，count，j As Integer count = 1 For i = 1 To 470 flag = False If count

1然后对于j = 1要计数如果Sheet1.Cells（i， 3）.Value = Sheet1.Cells（j，11）.Value然后标记 = True End If If j Else flag = False End If If flag = False Then Sheet1.Cells（count， 11）.Value = Sheet1.Cells（i，3）.Value count = count + 1 End IfNext i Sheet1.Cells（1， 15）.Value = count End Sub

Excel VBA - 收集错误

4 个答案: