Visual Basic for Applications (VBA) 对唯一单元格进行计数

Question

我正在尝试制作一个Visual Basic 宏来计算一行中的唯一项目，而无需进行复制和粘贴以及数据删除重复项。

出于某种原因，我的语法有问题。当我运行脚本时，它会输出行数。

这是我第一次用Visual Basic for Applications （VBA）编程。

Private Sub FrequencyCount_Click()
    Dim rng As Range
    Dim outcell As Range
    Dim outnum As Integer
    Dim MyArray() As Variant
    Dim ArrayLength As Integer
    Dim unique As Boolean
    Dim i
    outnum = 0
    ArrayLength = 1
    unique = False
    Set rng = Application.InputBox("Select a Range to Count Uniques", "Obtain Range Object", Type:=8)
    Set outcell = Application.InputBox("Select an Output Box for Uniques", "Obtain Range Object", Type:=8)

    For Each B In rng.Rows
        If outnum = 0 Then
            ReDim MyArray(1)
            MyArray(ArrayLength) = B.Value
            outnum = outnum + 1
            ArrayLength = ArrayLength + 1
        Else
           i = 0
           unique = True
           Do Until i < ArrayLength

              If MyArray(i) = B.Value Then
                  unique = False
              End If
              i = i + 1
           Loop
            MsgBox unique
            If unique = True Then
                ReDim Preserve MyArray(0 To ArrayLength + 1)
                MyArray(ArrayLength) = B.Value
                ArrayLength = ArrayLength + 1
                outnum = outnum + 1
            End If
        End If
        Next

    End
outcell.Value = outnum
End Sub

Answer 1

通常认为在循环中重新Dim 数组是不明智的做法，不建议这样做。如果你搜索互联网，那么会出现很多这样的讨论循环中的重新分配

您可以使用内置功能来到达所需的位置。应该适合您的示例代码。

    Sub FrequencyCount_Click()
        Dim rng As Range
        Dim outcell As Range
        Set rng = Application.InputBox("Select a Range to Count Uniques", "Obtain Range Object", Type:=8)
        Set outcell = Application.InputBox("Select an Output Box for Uniques", "Obtain Range Object", Type:=8)
        rng.Copy outcell.Cells(1, 1)
        outcell.Resize(rng.Cells.Count, 1).RemoveDuplicates 1, xlNo
    End Sub

Answer 2

正如@RyanWildry所建议的，你可以为此使用 Dictionary 对象。

调用该过程的代码还将定义包含重复项的范围以及要将唯一值粘贴到的起始范围：

Sub Test()
    'This will take values in the first range and paste the uniques starting at the second range cell.
    'NB:  Search for With...End With.
    With ThisWorkbook.Worksheets("Sheet1")
        FrequencyCount .Range("B2:B48"), .Range("D2")
    End With
End Sub

然后，

此代码会将值放入字典中，字典还会删除任何重复项，然后使用几种技术粘贴回行或列中。
我添加了很多评论，此链接可能有助于进一步阅读字典对象：https://excelmacromastery.com/vba-dictionary/

Public Sub FrequencyCount(SourceRange As Range, TargetRange As Range)
    Dim oDict As Object
    Dim rCell As Range
    Dim vKey As Variant
    Dim vArr As Variant
    Dim x As Long
    Set oDict = CreateObject("Scripting.Dictionary")
    oDict.comparemode = vbTextCompare 'Non-case sensitive.  Use vbBinaryCompare to make case sensitive.
    'Go through each cell in the source range and copy the value to the dictionary.
    For Each rCell In SourceRange
        'Change the value in the dictionary referenced by key value.
        'If key value doesn't exist create it.
        oDict(rCell.Value) = rCell.Value
    Next rCell
    'Paste in rows.
    x = 1
    ReDim vArr(1 To oDict.Count)
    For Each vKey In oDict.Keys
        vArr(x) = oDict(vKey)
        x = x + 1
    Next vKey
    TargetRange.Resize(UBound(vArr)) = WorksheetFunction.Transpose(vArr)
    'Paste in columns.
    TargetRange.Resize(1, UBound(Application.Transpose(oDict.Keys))) = oDict.Keys
End Sub

Answer 3

问题是你正在设置 i = 0 然后说

Do until i < arraylength`

好吧，如果i = 0，那么它将始终小于数组长度，这可能应该是

Do until i > arraylength 

希望这对:)有所帮助

Answer 4

这是一个更紧凑的解决方案，我从其他解决方案中拼凑而成。

Sub UniqueCountinSelection()
   Dim outcell As Range
   Dim itms As Object, c As Range, k, tmp As String
    Set rng = Application.InputBox("Select a Range to Count Uniques", "Obtain Range Object", Type:=8)
    Set outcell = Application.InputBox("Select an Output Box for Uniques", "Obtain Range Object", Type:=8)
    Set itms = CreateObject("scripting.dictionary")
    For Each c In rng
        tmp = Trim(c.Value) 'removes leading and trailing spaces
        If Len(tmp) > 0 Then itms(tmp) = itms(tmp) + 1
    Next c
outcell.Value = UBound(itms.Keys) + 1
End Sub