How to improve the performance of the code and to execute it in less time for VBA EXCEL code COUNTIF

Question

I hope you can help me to optimize this code block in VBA EXCEL. When I execute the block of code with less than 30 thousand records, it takes 3 minutes to execute.

I want your support to validate if there is a possibility to improve the performance of the code and to execute it in less time.

How could I improve that line so that it takes less time to execute? I hope that either of the two blocks of code can be taken as an example.

Thank you very much for your support

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

This code took '2 min.17 sec to execute and what it does is set a TRUE or FALSE flag. If it is FALSE, it sets the same FLAG to the original and the duplicate

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

This code took '2 min.08 sec to execute and what it does is set a 1 or 0 flag. If it is 0, it sets the same FLAG to the original and the duplicate

Answer 1

Please, try the next way. It must be very fast using arrays and working only in memory, and a Dictionary to identify the unique cases. It will place a flag only for the next occurrence (second, third, fourth and so on...). In this way it offers the possibility to sort by flag and delete duplicates, only unique cases remaining:

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

Answer 2

Flag Unique Values

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