如何提高代码的性能并在更少的时间内执行VBA Excel代码Countif

Question

希望您可以帮助我在VBA Excel中优化此代码块。当我执行少于3万个记录的代码块时，执行需要3分钟。

我希望您的支持能够验证是否有可能提高代码的性能并在更少的时间内执行它。

我该如何改进这条线以使执行时间更少？我希望可以以两个代码块中的任何一个为例。

非常感谢您的支持，

Sub findduplicates()

Dim ws As Worksheet: Set ws = ActiveSheet 'always specify a worksheet
      
    Range("BE1") = "Flag_Unico"
    
    With ws.Range("BE2:BE" & ws.Cells(Rows.count, "N").End(xlUp).Row)
        .Formula = "=COUNTIF(BD:BD,BD2)=1"
        .Value = .Value
    End With
            
End Sub

此代码花了2分钟。17秒执行且它的作用是设置一个真或错误的标志。如果是错误的，它将相同的标志设置为原始标志，并且重复

Sub findduplicates()

Dim ws As Worksheet: Set ws = ActiveSheet 'always specify a worksheet
      
    Range("BE1") = "Flag_Unico"
            
    With ws.Range("BE2:BE" & ws.Cells(Rows.count, "N").End(xlUp).Row)
        .Formula = "=IF(COUNTIF(BD:BD,BD2)=1,0,1)"
        .Value = .Value
    End With
    
End Sub

此代码花费了2分钟。08秒执行，并设置1或0标志。如果是0，它将相同的标志设置为原始标志和副本

Answer 1

标志唯一值

Option Explicit

Sub FlagUniques()

    ' Reference the worksheet ('ws').
    Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
    ' i.e. instead use e.g.
    'Set ws = ThisWorkbook.Worksheets("Sheet1")
    
    ' Write the header.
    ws.Range("BE1") = "Flag_Unico"
    
    ' Reference the source (one-column) range.
    With ws.Range("BD2:BD" & ws.Cells(ws.Rows.Count, "N").End(xlUp).Row)
    
        ' Write the number of rows to a variable ('rCount').
        Dim rCount As Long: rCount = .Rows.Count
    
        ' Write the values from the source range to the source array ('sData').
        Dim sData() As Variant: sData = .Value
        
        ' Reference a new dictionary object ('dict').
        With CreateObject("Scripting.Dictionary")
            .CompareMode = vbTextCompare ' case-insensitive; out-comment if not
            
            ' Write the unique values from the source array to the dictionary
            ' whose 'keys' will hold the unique value while each
            ' of the corresponding 'items' will hold the count.
            
            Dim r As Long ' Current Row
            
            For r = 1 To rCount
                .Item(sData(r, 1)) = .Item(sData(r, 1)) + 1
            Next r
            
            ' Write the 'True/False' results to the destination array ('dData').
            
            Dim dData() As Boolean: ReDim dData(1 To rCount, 1 To 1)

            For r = 1 To rCount
                If .Item(sData(r, 1)) = 1 Then ' the count is '1'
                    dData(r, 1) = True
                'Else ' the count is '>1'; the default value is 'False'
                End If
            Next r
        
' Or:
'            ' Write the '1/0' results to the destination array ('dData').
'
'            Dim dData() As Long: ReDim dData(1 To rCount, 1 To 1)
'
'            For r = 1 To rCount
'                If .Item(sData(r, 1)) = 1 Then ' the count is '1'
'                    dData(r, 1) = 1
'                'Else ' the count is '>1'; the default value is '0'
'                End If
'            Next r
        
        End With
        
        ' Write the results from the destination array to the destination range.

        ' Reference the destination (one-column) range.
        With .EntireRow.Columns("BE")
            ' Write.
            .Value = dData
            ' Clear below.
            .Resize(ws.Rows.Count - .Row - rCount + 1).Offset(rCount).Clear
        End With
        
    End With
            
    ' Inform to not wonder if the code has run or not.
    MsgBox "Unique values flagged.", vbInformation

End Sub

Answer 2

拜托，请尝试下一步。它必须使用数组非常快，并且仅在内存中工作，并且字典以识别唯一的情况。它将仅在下一次发生（第二，第三，第四，依此类推...）时将标志放置。通过这种方式，它提供了通过标志和删除重复项进行排序的可能性，仅剩下独特的情况：

Sub findDuplicatesBis()
   Dim ws As Worksheet, arrBD, arrBE, i As Long, dict As Object
   
   Set ws = ActiveSheet
   arrBD = ws.Range("BD2:BD" & ws.cells(ws.rows.count, "BD").End(xlUp).row).Value2
   ReDim arrBE(1 To UBound(arrBD), 1 To 1)
   Set dict = CreateObject("Scripting.Dictionary")

   For i = 1 To UBound(arrBD)
        If Not dict.Exists(arrBD(i, 1)) Then
            dict.Add arrBD(i, 1), 1
        Else
            arrBE(i, 1) = "Duplicate"
        End If
   Next i
   ws.Range("BE1") = "Flag_Unico"
   ws.Range("BE2").Resize(UBound(arrBE), 1).Value2 = arrBE
End Sub