如何仅对 excel 列中的条目进行一定次数的计数?

How to count entries in excel column only certain number of times?

我想统计一下某个公司按照某个标准被审核了多少次。如果F栏中的XYZ公司根据C栏中的某个标准进行了3次以上的审核,则其中3家公司应计为1、2和3。 如果一家公司被审核2次,则应计为1次和2次。 如果一家公司只被审核一次,则应计为1次。

示例如下(G 列是期望的结果):

我已经有一个代码,遗憾的是不能满足所有要求。

是否可以相应调整?

Sub GroupCertificates_MAX3()
Dim Ws As Worksheet
Dim rngDB As Range, vDB As Variant
Dim s1, s2
Dim r As Long, i As Long
Dim k As Long, n As Long

Set Ws = ActiveSheet

Set rngDB = Ws.UsedRange.Offset(1)
vDB = rngDB

r = UBound(vDB, 1)
s1 = vDB(1, 2)
s2 = vDB(1, 5)

k = 1
For i = 1 To r
    If vDB(i, 2) = s1 And vDB(i, 5) = s2 Then
        n = n + 1
    Else
        vDB(k, 7) = WorksheetFunction.Min(3, n)
        k = i
        n = 1
        s1 = vDB(i, 2)
        s2 = vDB(i, 5)
    End If
Next i
rngDB = vDB

End Sub

这是一个嵌套词典的作业。意识到一个词典项目可以是另一个词典可能有点费劲。此外,如果没有 'with' 语法,事情很快就会变得非常冗长

Public Sub CountUsingDictionaries()

    Dim myCompanies As Variant
    myCompanies = GetColumnArrayFromExcel(ThisWorkbook.Sheets(1).Range("F2:F11"))
    
    Dim myStandard As Variant
    myStandard = GetColumnArrayFromExcel(ThisWorkbook.Sheets.Item(1).Range("B2:B11"))
    
    Dim myCounter As Scripting.Dictionary
    Set myCounter = New Scripting.Dictionary
    
    Dim myResult As Scripting.Dictionary
    Set myResult = New Scripting.Dictionary
    
    Dim myIndex As Long
    For myIndex = LBound(myCompanies) To UBound(myCompanies)
    
        Dim myCKey As String
        myCKey = myCompanies(myIndex)
        
        Dim mySKey As String
        mySKey = myStandard(myIndex)
        
        If Not myCounter.exists(myCKey) Then
        
            myCounter.Add myCKey, New Scripting.Dictionary
            
        End If
        
        With myCounter.Item(myCKey)
        
            If Not .exists(mySKey) Then
            
                .Add mySKey, 0
                
            End If
            
            .Item(mySKey) = .Item(mySKey) + 1
            
            If .Item(mySKey) > 3 Then
            
                myResult.Add myIndex, " "
                
            Else
            
                myResult.Add myIndex, .Item(mySKey)
                
            End If
            
        End With
        
    Next
    
    ThisWorkbook.Sheets.Item(1).Range("G2:G11") = Application.WorksheetFunction.Transpose(myResult.Items)
        
End Sub


Public Function GetColumnArrayFromExcel(ByVal ipRange As Excel.Range) As Variant
' This is a workaround for an idiosyncracy of Excel which returns a
' 2D variant array when the request is only for a 1D array
' If you need an array from a row then you need two transpose actions

    GetColumnArrayFromExcel = Application.WorksheetFunction.Transpose(ipRange.Value)

End Function

上面的代码是使用

测试的

您可以使用普通 excel 公式,但使用 VBA,然后粘贴值。代码确实会更简单:

Dim LR As Long
LR = Range("A" & Rows.Count).End(xlUp).Row 'we get last non empty row in column A

Range("F2:F" & LR).FormulaR1C1 = _
        "=IF(COUNTIFS(R2C2:RC[-4],RC[-4],R2C5:RC[-1],RC[-1])>3,"""",COUNTIFS(R2C2:RC[-4],RC[-4],R2C5:RC[-1],RC[-1]))" 'we calculate
Range("F2:F" & LR) = Range("F2:F" & LR).Value 'we past as values (optional)

如果您想知道,我使用的是动态范围公式:

=IF(COUNTIFS($B:B2;B2;$E:E2;E2)>3;"";COUNTIFS($B:B2;B2;$E:E2;E2))