VBA在选定的单元格中找到重复项并计算它们

Posted 2023-03-29

【中文标题】VBA在选定的单元格中找到重复项并计算它们

【英文标题】：VBA find duplicate in selected cells and count them

【发布时间】：2021-03-22 22:40:46

【问题描述】：

我在这个论坛上阅读了很多关于我的问题的帖子，但找不到解决方案。 我有一个包含不同数量的单元格的表格，具有重复的值。 我想计算重复项并显示在其他列中。

我标记几个单元格的源表：

我想收到这样的输出

A 有一部分代码，但无论我选择什么，它都会计算最后一个单元格

Dim rng, rngTarget, rngTargetName As Range
Set rngTarget = Range("D7")

Set items = CreateObject("Scripting.Dictionary")

For Each rng In Selection
       If Not items.exists(rng.Value) Then
        items.Add rng.Value, 1
        rngTarget.Value = items(rng.Value)
        rngTargetName = rng
    Else
        items(rng.Value) = items(rng.Value) + 1
        rngTarget.Value = items(rng.Value)
        rngTargetName = rng
    End If

Next

我错过了什么？

【参考方案1】：

首先在标准模块中输入：

Public Function unikue(rng As Range)
    Dim arr, c As Collection, r As Range
    Dim nCall As Long, nColl As Long
    Dim i As Long
    Set c = New Collection
    
    nCall = Application.Caller.Count
    
    On Error Resume Next
        For Each r In rng
            If r.Value <> "" Then
                c.Add r.Text, CStr(r.Text)
            End If
        Next r
    On Error GoTo 0
    nColl = c.Count
    
    
    If nCall > nColl Then
        ReDim arr(1 To nCall, 1 To 1)
        For i = 1 To nCall
            arr(i, 1) = ""
        Next i
    Else
        ReDim arr(1 To nColl, 1 To 1)
    End If
    
    For i = 1 To nColl
        arr(i, 1) = c.Item(i)
    Next i
    
    unikue = arr
End Function

上面的 UDF() 将返回一个单元格块中唯一的非空白项的列表。

然后在列中的一组单元格中，说 F 从 F5 开始，array-enter:

=unikue(A1:D3)

在G5中输入：

=COUNTIF($A$1:$D$3,F5)

并向下复制：

使用 Excel 365，有一个无 VBA 的解决方案。

【参考方案2】：

感谢 Gary 的帮助，但是... 我完成了我的代码版本，现在可以按预期工作 - 我可以选择几个单元格并计算重复项。

我的工作代码：

 Dim rng As Range
    Dim var As Variant
    Dim i As Integer
    i = 0
    Set D = CreateObject("Scripting.Dictionary")
    For Each rng In Selection
        If rng <> "" Then
            If D.exists(rng.Value) Then
                D(rng.Value) = D(rng.Value) + 1
            Else
                D.Add rng.Value, 1
            End If
        End If
    Next
    For Each var In D.Keys
        Range("C" & (i + 18)) = var
        Range("E" & (i + 18)) = D(var)
        i = i + 1
    Next
Set D = Nothing