Incement a cell then keep it

[Cpt_kludge]

I have a column of about 5000 names. I add to this column regularly and have it the conditions set to show me duplicates. I then delete them.
I want to have a count of how many times I have tried to add a name that is already on the list, then KEEP that value showing me the names that have come up the most. Over time this will show me the names with the most activity. The date currently is in D column and starts on Row 2

In A2 I have used =COUNTIF(D:D, D2) to tell me the number of times D2 appears in the column. It is a value of 1 and will change to the number of duplicates found in the column.
In B2 I have =IF(A2>1, A2+1, B2) this should make B2 increment +1 each time that A2 is >1. It returns the number of duplicates +1 but does not keep this number once the duplicates are removed. Anyidea how I can keep this number and incrament it by the number of dupicates? I tried =abs, but could not get that to work.
Thanks from a Newby
Joe

 

[James006]

Hello,

You could test the following event macro ...

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Target.Column <> 4 Then Exit Sub
Dim last As Long
Dim res As Variant
  last = Sheet1.Cells(Rows.Count, "A").End(xlUp).Row
  If Target = "" Then
    Range("A" & Target.Row).Resize(, 4).ClearContents
  Else
    Target.Offset(0, -3).FormulaR1C1 = "=COUNTIF(C[3], RC[3])"
    Target.Offset(0, -1).Value = 0
    res = Application.Match(Target.Value, Range("D1:D" & last), 0)
    If IsError(res) Then
      Target.Offset(0, -2) = 1
    Else
      Range("B" & res) = Range("B" & res) + 1
      Target.Offset(0, -2) = Range("B" & res)
    End If
  End If
End Sub

Hope this will help

 

[Cpt_kludge]

I tried this and it seems the same.
If I add names to Column D that are duplicates, for the original rows, Column A goes to 1+ however duplicated there are . Column B goes to Column A+1.
Then when the duplicates are removed, column's A & B return to their original values.
Is there a way to lock a cell so it can ONLY be added to and the value kept after the formula driving that secondary returns to its original.? so that a formula can add to a cell but NEVER subtract from it?
Beginning to thing this is something that cannot be done
Thanks for your help IAC

 

[Cpt_kludge]

I took out the event macro (made it blank) saved it and ran it again.
AFAICT the event macro is having NO effect (or I am doing it totally wrong)
TIA

 

[Fluff]

Replace the formula in Col A with 1s & then try

Private Sub Worksheet_Change(ByVal Target As Range)
   Dim x As Variant

   If Target.Count > 1 Then Exit Sub
   If Target.Column <> 4 Then Exit Sub
   Application.EnableEvents = False
   x = Application.Match(Target, Range("D1:D" & Target.Row - 1), 0)
   If Not IsError(x) Then Range("A" & x).Value = Range("A" & x).Value + 1
   Application.EnableEvents = True
End Sub

This needs to go in the sheet module, Right click the sheet tab > view code > Paste the code in the window that opens up

 

[Fluff]

Cross posted https://www.excelforum.com/excel-formulas-and-functions/1257591-counting-duplicates.html#post5032560

While we do not prohibit Cross-Posting on this site, we do ask that you please mention you are doing so and provide links in each of the threads pointing to the other thread (see rule 13 here along with the explanation: Forum Rules).
This way, other members can see what has already been done in regards to a question, and do not waste time working on a question that may already be answered.

 

[Cpt_kludge]

Thanks Fluff.
I took the file you had modified and added duplicats (by copying and pasting from column D to column D)
The conditional formatting highlighted the duplicates, but nothing in column A changed All cells remained "1"
Beginning to think this is not possible!
Thanks and Merry Christmas!

 

[Fluff]

How are you entering the data?

 

[Cpt_kludge]

Re: Incement a cell then keep it [SOLVED]

In a column cut and pasted from notepad.
I am calling this as solved due to your and Jason.b75's efforts
Here is the code I am using and seems to work GREAT

<code>Private Sub Worksheet_Change(ByVal Target As Range)
   Dim x As Variant, c As Range
   If Target.Column <> 2 Or Target.Row = 1 Then Exit Sub
   Application.EnableEvents = False
      For Each c In Target
         If Len(c.Value) > 0 Then
            x = Application.Match(c, Range("B1:B" & c.Row - 1), 0)
            If Not IsError(x) Then Range("A" & x).Value = Range("A" & x).Value + 1 Else Range("A" & c.Row).Value = 1
         End IF
      Next
   Application.EnableEvents = True
End Sub

Thanks for eveyon'es help! This has been a learning experience
</code>