VBA |如何计算不同值的出现次数？

Posted 2023-03-27

【中文标题】VBA |如何计算不同值的出现次数？

【英文标题】：VBA | How to count occurrences for distinct values?

【发布时间】：2021-06-26 11:58:06

【问题描述】：

谁能帮助解决以下问题？ 如何计算 Column "A" 中的每个不同值在 Column "B" 中的值出现多少次（例如 ">30"）？在完美的世界中，这将是多个标准。

在 A:B 列 - 源数据中，E:F 列是预期结果。此外，它可以在两张纸之间分开。

Source data and expected result

到目前为止，我发现的代码仅将唯一值从一张纸提取到另一张纸，并计算其在整个范围内的出现次数。

Sub UniqueIdentifiers()
Dim lastRow As Long
Dim count As Integer, i As Integer, j As Integer
lastRow = Sheets(1).Range("E" & Rows.count).End(xlUp).Row
i = 2
j = 2
Do Until i > lastRow
    count = Application.WorksheetFunction.CountIf(Sheets(1).Range("C2:C" & lastRow), Sheets(1).Cells(i, 3))
        For Each c In Sheets(1).Range("C" & lastRow).Cells
        
            Sheets(2).Cells(j, 1) = Sheets(1).Cells(i, 3)
            Sheets(2).Cells(j, 2) = count
            
            j = j + 1
            
        Next
    i = i + 1
Loop
    Sheets(2).Range("A:B").RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
        
End Sub

更新 - 问题已解决

感谢@Gary 在Excel VBA find unique values in combinations of 2 or more columns 问题中的学生回答，我已经设法找到解决我的任务的问题，如果条件刚刚添加到他的代码中。完整代码如下：

Sub uniKue()
    Dim i As Long, N As Long, s As String, r As Range
    N = Cells(Rows.count, "A").End(xlUp).Row
    For i = 2 To N
        If Cells(i, 4) >= 30 Then
        Cells(i, 5) = Cells(i, 2) & " " & Cells(i, 5)
        Cells(i, 6) = Cells(i, 5)
    End If
    Next i
    Range("F:F").RemoveDuplicates Columns:=1, Header:=xlNo
    For Each r In Range("F:F").SpecialCells(2).Offset(, 1)
        r.Formula = "=COUNTIF(E:E," & r.Offset(, -1).Address & ")"
    Next r
End Sub

感谢大家的贡献。

【问题讨论】：

只使用COUNTIFS有什么问题？

这将是另一个宏的一部分，我宁愿在 vba 中这样做，以避免每次都写公式

您可以使用 VBA 编写公式。

【参考方案1】：

这会遍历 A 列 中的 NR 列表并找到每个实例，然后将其添加到 E 列（如果它不存在）。如果它存在，则每次在 F 列

中找到此实例时，它都会加 1

Option Explicit
Sub UniqueIdentifiers()

Dim Nrs As Range 'list all Nrs
Dim Nr As Range 'each indiviual Nr in the list of Nrs
Dim Item As Range 'each indivual item in the other column
Dim adder As Range 'used to find item and add it if nessesary

Set Nrs = Range("a2", Range("a2").End(xlDown)) 'you can also change this ofcourse to a specific range or user selected


For Each Nr In Nrs
    Set adder = Range("e2", Range("e2").End(xlDown)).Find(Nr)
    If adder Is Nothing Then
        If Range("e2") = "" Then
            Set Item = Range("e2")
        Else
            Set Item = Range("e1").End(xlDown).Offset(1, 0)
        End If
        Item.Value = Nr.Value
        Item.Offset(0, 1) = 1
    Else
        adder.Offset(0, 1).Value = adder.Offset(0, 1).Value + 1
    End If
Next Nr


End Sub

【参考方案2】：

唯一计数（字典）

调整常量部分中的值。此外，如有必要，请在'*** 处调整大于 (>)。

Option Explicit

Sub UniqueIdentifiers()
    
    Const sName As String = "Sheet1"
    Const sFirst As String = "A2"
    Const sCrit As Double = 30
    
    Const dName As String = "Sheet1"
    Const dFirst As String = "E2"
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sCell As Range
    Dim Data As Variant
    Dim wasDataFound As Boolean
    
    With wb.Worksheets(sName).Range(sFirst)
        Set sCell = .Resize(.Worksheet.Rows.count - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If Not sCell Is Nothing Then
            Data = .Resize(sCell.Row - .Row + 1, 2).Value
            wasDataFound = True
        End If
    End With
    
    If wasDataFound Then

        Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
        Dim i As Long
    
        For i = 1 To UBound(Data, 1)
            If Data(i, 2) > sCrit Then '***
                dict(Data(i, 1)) = dict(Data(i, 1)) + 1
            Else
                If Not dict.Exists(Data(i, 1)) Then
                    dict(Data(i, 1)) = 0
                End If
            End If
        Next i
    
        If dict.Count > 0 Then
            
            ReDim Data(1 To dict.Count, 1 To 2)
            i = 0
            
            Dim Key As Variant
            
            For Each Key In dict.Keys
                i = i + 1
                Data(i, 1) = Key
                Data(i, 2) = dict(Key)
            Next Key
            
            With wb.Worksheets(dName).Range(dFirst).Resize(, 2)
                .Resize(i).Value = Data
                .Resize(.Worksheet.Rows.count - .Row - i + 1) _
                    .Offset(i).ClearContents
            End With
            
        End If
    
    Else
    
        MsgBox "No data found.", vbExclamation, "No Data"
    
    End If

End Sub