Vba 有更快的倒计时吗

正如标题所说。是否有任何函数或VBA代码可以实现与countif相同的功能，并且速度更快。目前在大范围的中间，它正在吞噬我的CPU。 这只是工作表中的一个基本计数。不是在VBA中。

---

=countif（X:X，Y）

但是列表非常庞大。因此，这两个列表大约有100000行

如果您不需要计算发生次数，只需检查y列中是否存在值x，则通过计算查找返回布尔值TRUE或FALSE将大大加快过程

=ISNUMBER(MATCH(S1, Y:Y, 0))

根据需要填写以获取所有退货。对返回值进行排序和/或筛选，以将结果制成表格

附录：

显然有。在计算时间上的巨大改进使我怀疑匹配是否不能放入循环中，将其lookup_数组参数中的第一个单元格前进到先前返回的行号加1，直到不再有匹配为止。此外，通过按返回的行号调整（收缩）列的高度，可以对越来越小的lookup_数组单元格范围进行后续匹配调用，以查找相同的数字（增加计数）。如果处理后的值及其计数作为键和项存储在脚本字典中，则无需处理计数即可立即解析重复值

Sub formula_countif_test()
    Dim tmr As Double
    appOFF
    tmr = Timer
    With Sheet2.Cells(1, 1).CurrentRegion
        With .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count) 'skip header
            .Cells(1, 3).Resize(.Rows.Count, 1).FormulaR1C1 = _
                "=countif(c1, rc2)"  'no need for calculate when blocking in formulas like this
        End With
    End With
    Debug.Print "COUNTIF formula: " & Timer - tmr
    appON
End Sub

Sub formula_match_test()
    Dim rw As Long, mrw As Long, tmr As Double, vKEY As Variant
    'the following requires Tools, References, Microsoft Scripting Dictionary
    Dim dVALs As New Scripting.dictionary
    
    dVALs.CompareMode = vbBinaryCompare  'vbtextcompare for non-case sensitive
    
    appOFF
    tmr = Timer
    
    With Sheet2.Cells(1, 1).CurrentRegion
        With .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count) 'skip header
            For rw = 1 To .Rows.Count
                vKEY = .Cells(rw, 2).Value2
                If Not dVALs.Exists(vKEY) Then
                    dVALs.Add Key:=vKEY, _
                        Item:=Abs(IsNumeric(Application.Match(vKEY, .Columns(1), 0)))
                    If CBool(dVALs.Item(vKEY)) Then
                        mrw = 0: dVALs.Item(vKEY) = 0
                        Do While IsNumeric(Application.Match(vKEY, .Columns(1).Offset(mrw, 0).Resize(.Rows.Count - mrw + 1, 1), 0))
                            mrw = mrw + Application.Match(vKEY, .Columns(1).Offset(mrw, 0).Resize(.Rows.Count - mrw + 1, 1), 0)
                            dVALs.Item(vKEY) = CLng(dVALs.Item(vKEY)) + 1
                        Loop
                    End If
                    .Cells(rw, 3) = CLng(dVALs.Item(vKEY))
                Else
                    .Cells(rw, 3) = CLng(dVALs.Item(vKEY))
                End If
            Next rw
        End With
    End With
    Debug.Print "MATCH formula: " & Timer - tmr
    dVALs.RemoveAll: Set dVALs = Nothing
    appON
End Sub

Sub appON(Optional ws As Worksheet)
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
End Sub

Sub appOFF(Optional ws As Worksheet)
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
End Sub

我使用了10K行，A列和B列由

randbween（1999）

填充，然后复制并粘贴为值

运行时间：

测试1М-10K行×2列，填充RANDBETWEEN（1999）
计数公式：15.488秒
匹配公式：1.592秒

测试2²-10K行×2列，填充RANDBETWEEN（199999）
计数公式：14.722秒
匹配公式：3.484秒

我还将COUNTIF公式中的值复制到另一列中，并将它们与编码匹配函数返回的值进行比较。它们在10K行中是相同的。
多一倍；小于零计数
²零计数越多，倍数越小

虽然数据的性质显然会产生显著差异，但编码匹配函数每次都优于本机COUNTIF工作表函数

不要忘记VBE的工具► 工具书类► Microsoft脚本字典。

尝试

sumproduct（countif（x:x，y:y））

速度稍微快一点，但我不确定速度有多快。

---

另外，如果您找到了更好的选择，请告诉我们。

在对数据进行排序后，COUNTIF有一个简单的解决方法。您可以将其添加到VB脚本中，然后运行。对于大约有10万行项目的数据，正常计数几乎需要10-15分钟。此脚本将获取计数，但不确定它是否更快，但您可以尝试过滤

if

部分中的列，然后获取

范围.SpecialCells（xlVisible）.Count

。注意：并非100%确定

xlVisible

是正确的枚举，但您知道了。我所要做的就是查看x列表是否在y列表中。我只要零。因此，我不确定我是否可以这样分割它，它只是实际工作表中的一个简单工作簿函数，

=countif（X:X，y）

，但是列表非常庞大。您是否试图获取两个列表中出现的值的数量？我试图计算列表y中的某个内容出现在列表中的次数XHello，关于这方面的几个问题；1） 这个函数实际上在做什么2）它在不排序列的情况下工作吗（我有20列要计数）3）你能摆脱消息框导入，只在顶部编码为icol=1吗

Sub alternateFunctionForCountIF()
    Dim DS As Worksheet
    Set DS = ThisWorkbook.ActiveSheet
    
    Dim lcol As Integer
    lcol = DS.Cells(1, Columns.Count).End(xlToLeft).Column
    Dim fieldHeader As String
    
    Dim lrow As Long, i As Long, j As Long
    Dim countifCol As Integer, fieldCol As Integer
    
    fieldHeader = InputBox("Enter the column header to apply COUNTIF")
    If Len(fieldHeader) = 0 Then
        MsgBox ("Invalid input. " & Chr(13) & "Please enter the column header text and try again")
        Exit Sub
    End If
    For i = 1 To lcol
        If fieldHeader = DS.Cells(1, i).Value Then
            fieldCol = i
            Exit For
        End If
    Next i
    If fieldCol = 0 Then
        MsgBox (fieldHeader & " could not be found among the headers. Please enter a valid column header")
        Exit Sub
    End If
    
    countifCol = fieldCol + 1
    lrow = DS.Cells(Rows.Count, "A").End(xlUp).Row
    DS.Range(DS.Cells(1, countifCol).EntireColumn, DS.Cells(1, countifCol).EntireColumn).Insert
    DS.Cells(1, countifCol) = fieldHeader & "_count"
    
    DS.Sort.SortFields.Clear
    DS.Sort.SortFields.Add Key:=Range(DS.Cells(2, fieldCol), DS.Cells(lrow, fieldCol)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With DS.Sort
        .SetRange Range(DS.Cells(1, 1), DS.Cells(lrow, lcol))
        .header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    Dim startPos As Long, endPos As Long
    Dim checkText As String
    For i = 2 To lrow
        checkText = LCase(CStr(DS.Cells(i, fieldCol).Value))
        
        If (checkText <> LCase(CStr(DS.Cells(i - 1, fieldCol).Value))) Then
            startPos = i
        End If
        If (checkText <> LCase(CStr(DS.Cells(i + 1, fieldCol).Value))) Then
            endPos = i
            For j = startPos To endPos
                 DS.Cells(j, countifCol) = endPos - startPos + 1
            Next j
        End If
    Next i
    MsgBox ("Done")
End Sub