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

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

CodePudding user response：

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 New Scripting.Dictionary
   
   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)
   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("BE2").Resize(UBound(arrBE), 1).Value2 = arrBE
End Sub

CodePudding user response：

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