get duplicate count in sheet2 in this vba

Unique List in a Worksheet Change

• It is triggered when cells in the range A2:D1048576 (former A2:D65536) are 'modified' (even if you click into it and press enter, not changing the value).
• It uses a dictionary whose keys hold the unique values and whose items hold their count.
• It will write the values from the A:D range to an array which will be modified appropriately (results written to the top, array increased by a column, count written to the extra column), and used to write the unique values to the destination. The dr variable holds the number of rows of the result.
• It will copy only values and clear the range below the results.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

    On Error GoTo ClearError

    Const sCols As String = "A:D"
    Const sfRow As Long = 2
    Const sDupeColumn As Long = 1

    Const dfCellAddress As String = "A2"

    Dim sfrrg As Range: Set sfrrg = Me.Rows(sfRow).Columns(sCols)
    Dim scrg As Range: Set scrg = sfrrg.Resize(Me.Rows.Count - sfrrg.Row + 1)

    If Intersect(scrg, Target) Is Nothing Then Exit Sub ' no intersection

    Dim slRow As Long
    slRow = Me.Cells(Me.Rows.Count, sDupeColumn).End(xlUp).Row
    If slRow < sfRow Then Exit Sub ' no data

    Dim srCount As Long: srCount = slRow - sfRow + 1
    Dim srg As Range: Set srg = sfrrg.Resize(srCount)
    Dim scCount As Long: scCount = srg.Columns.Count

    Dim Data As Variant: Data = srg.Value

    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare

    Dim sKey As Variant
    Dim sr As Long
    Dim dr As Long
    Dim c As Long

    For sr = 1 To UBound(Data)
        sKey = Data(sr, sDupeColumn)
        If Not IsError(sKey) Then
            If Not IsEmpty(sKey) Then
                If dict.Exists(sKey) Then
                    dict(sKey) = dict(sKey) + 1
                Else
                    dr = dr + 1
                    dict(sKey) = 1
                    For c = 1 To scCount
                        Data(dr, c) = Data(sr, c)
                    Next c
                End If
            End If
        End If
    Next sr

    Dim dcCount As Long: dcCount = scCount + 1
    ReDim Preserve Data(1 To srCount, 1 To dcCount)
    dr = 0

    For Each sKey In dict.Keys
        dr = dr + 1
        Data(dr, dcCount) = dict(sKey)
    Next sKey

    Dim dfCell As Range: Set dfCell = Sheet2.Range(dfCellAddress)
    Dim drg As Range: Set drg = dfCell.Resize(dr, dcCount)

    Application.EnableEvents = False ' before writing

    ' Copy
    'srg.Copy dfCell ' if you need the formatting
    drg.Value = Data
    
    ' Clear below.
    Dim dcrg As Range
    Set dcrg = drg.Resize(Sheet2.Rows.Count - drg.Row - dr + 1).Offset(dr)
    dcrg.Clear

SafeExit:
    If Application.EnableEvents = False Then
        Application.EnableEvents = True ' after writing
    End If
    
    Exit Sub
ClearError:
    Debug.Print "Run-time error'" & Err.Number & "': " & Err.Description
    Resume SafeExit
End Sub

i use matrix formula

you type

=SUM(IF($A$1:$A$11=B1;1;0))

and press CTRL+SHIFT+ENTER to turn our formula to matrix formula then you can copy to other cells

answering your comment

you can get duplicates with matrix formulate but with many lines like 7000 can take more time for your pc calculate the worksheet around 20seconds

look the image, i put numbers in "A2:B16" and make first one cell with matrix formulate(B2) type:

=IFERROR(INDEX($A$2:$A$16; MATCH(0; COUNTIF(B$1:$B1; $A$2:$A$16); 0));"")

and before exit press CTRL+SHIFT+ENTER to turn our formula to matrix formula then you can copy to other cells

and to count duplicates just type

=CONTIF($A$2:$A$16;B2)

em press ENTER ,after copy and paste above