VBA计数器去重需求：实现符合条件的唯一值统计

问题核心 #

原代码对F列的唯一值，只要在AE列找到多个符合条件的匹配行就重复累加计数，需改为每个符合条件的F列唯一值仅计1次。

修改思路 #

利用VBA的Dictionary对象（无需额外引用，用CreateObject直接创建）记录已统计的F列值，借助字典键的唯一性避免重复计数；或者在遍历F列时，一旦发现当前值满足条件，立即标记并跳过后续匹配检查。

完整修改代码 #

Sub CountUniqueMatches()
    Dim lr1 As Long, lr2 As Long
    Dim count As Long, counter As Long
    Dim x As Long, y As Long
    Dim currentF As String
    ' 用字典存储已统计的唯一值
    Dim uniqueBOM As Object, uniqueStock As Object
    
    ' 初始化字典
    Set uniqueBOM = CreateObject("Scripting.Dictionary")
    Set uniqueStock = CreateObject("Scripting.Dictionary")
    
    lr1 = Cells(Rows.Count, "F").End(xlUp).Row
    lr2 = Cells(Rows.Count, "AE").End(xlUp).Row
    
    '••••••••••••••••• 统计符合ACTIVE BOM条件的唯一值 •••••••••••••••••
    For x = 3 To lr1
        currentF = Range("F" & x).Value
        ' 未统计过该值才进入检查
        If Not uniqueBOM.Exists(currentF) Then
            For y = 3 To lr2
                If Range("F" & x) = Range("AE" & y) Then
                    If UCase(Range("AH" & y)) = "OB" Then
                        If Range("AO" & y) <> "" Then
                            If UCase(Range("AP" & y)) <> "OB" Then
                                ' 标记该值已统计
                                uniqueBOM.Add currentF, 1
                                count = count + 1
                                ' 找到符合条件的项就跳出循环，避免重复检查
                                Exit For
                            End If
                        End If
                    End If
                End If
            Next y
        End If
    Next x
    
    ' 输出J2结果
    If count > 0 Then
        Range("J2") = count & " found"
        Range("J2").Font.Color = vbRed
    Else
        Range("J2") = "None"
        Range("J2").Font.ColorIndex = 10
    End If
    
    '••••••••••••••••• 统计符合库存条件的唯一值 •••••••••••••••••
    For x = 3 To lr1
        currentF = Range("F" & x).Value
        If Not uniqueStock.Exists(currentF) Then
            For y = 3 To lr2
                If Range("F" & x) = Range("AE" & y) Then
                    If UCase(Range("AH" & y)) = "OB" Then
                        If Range("AM" & y) <> "0" Then
                            uniqueStock.Add currentF, 1
                            counter = counter + 1
                            Exit For
                        End If
                    End If
                End If
            Next y
        End If
    Next x
    
    ' 输出K2结果
    If counter > 0 Then
        Range("K2") = counter & " on stock"
        Range("K2").Font.Color = vbRed
    Else
        Range("K2") = "None"
        Range("K2").Font.ColorIndex = 10
    End If
    
    ' 释放对象
    Set uniqueBOM = Nothing
    Set uniqueStock = Nothing
End Sub

关键修改点 #

• 字典去重：通过Dictionary的Exists方法判断当前F值是否已统计，确保每个唯一值只计数一次。
• 提前终止循环：找到符合条件的匹配项后，用Exit For跳出内层循环，避免同一F值的重复检查，提升效率。

新手友好的替代方案（无需字典） #

如果不想用字典，可通过标记变量实现：

' 以第一个统计为例
For x = 3 To lr1
    Dim isCounted As Boolean
    isCounted = False
    For y = 3 To lr2
        If Not isCounted Then
            If Range("F" & x) = Range("AE" & y) Then
                ' 原条件判断逻辑
                If UCase(Range("AH" & y)) = "OB" And Range("AO" & y) <> "" And UCase(Range("AP" & y)) <> "OB" Then
                    count = count + 1
                    isCounted = True ' 标记为已统计，后续不再处理
                End If
            End If
        End If
    Next y
Next x

逻辑是每个F值仅在第一次找到符合条件的匹配时计数，后续匹配直接跳过。

内容的提问来源于stack exchange，提问作者Pom