如何仅计算excel列中的条目一定次数？

Question

我想统计一下某家公司按某种标准审核了多少次。 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

Answer 1

这是嵌套字典的工作。 意识到一个字典项目可以是另一个字典，这可能有点令人费解。 此外，如果没有“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

上面的代码使用测试

Answer 2

您可以使用普通的 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$2:B2;B2;$E$2:E2;E2)>3;"";COUNTIFS($B$2:B2;B2;$E$2:E2;E2))