get duplicate count in sheet2 in this vba-CodePudding

i have applied this vba code to copy unique data to sheet2 from sheet1 when i do data entry in sheet1 & this vba is perfectly working for me & here i want how to add get count of duplicates in column E of each entry data in sheet2 of duplicates in sheet1

i doing data entry in column A to column D sheet1


Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Sheet1.Range("A2:D" & Range("A" & Rows.Count).End(xlUp).Row).Copy Sheet2.Range("A2:D" & Rows.Count).End(xlUp).Offset(1, 0)
Sheet2.Range("A2", Sheet2.Range("D" & Rows.Count).End(xlUp)).RemoveDuplicates 1
End Sub

CodePudding user response：

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

    Application.EnableEvents = False

    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)
    
    ' 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
    Debug.Print dcrg.Address
SafeExit:
    If Application.EnableEvents = False Then
        Application.EnableEvents = True
    End If
    
    Exit Sub
ClearError:
    Debug.Print "Run-time error'" & Err.Number & "': " & Err.Description
    Resume SafeExit
End Sub

CodePudding user response：

i use matricial formula

you type

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

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