count duplicate value and report number of duplicate in each row with excel vba

Question

Column A have many ID, there are duplicate value such as cell(A2) ID 300502489400, cell(A3) ID 300502520900, cell(A4) ID 300502520900, cell(A5) ID 300502520900, cell(A6) ID 300502523900, cell(A7) ID 300502520900,

i need to count number of duplicate and report in Column B result such as cell(B2) =1, cell(B3) =4, cell(B4) =4, cell(B5) =4, cell(B6) =1, cell(B7) =1,

how can i code VBA in excel? I think it should loop to bring value in each row compare to all value and count.

Answer 1

You can use function to check range and count duplicate items

Function CountThisItem(CountingRange As Range, a As String) As Integer
Dim rng_FindRange As Range
Dim LA As String

Set rng_FindRange = CountingRange.Find(a, lookat:=xlWhole)
If Not rng_FindRange Is Nothing Then
    LA = rng_FindRange.Address
    CountThisItem = 1
    Do
        Set rng_FindRange = CountingRange.Find(a, lookat:=xlWhole, after:=rng_FindRange)
        If Not rng_FindRange Is Nothing And rng_FindRange.Address <> LA Then CountThisItem = CountThisItem + 1
    Loop While rng_FindRange.Address <> LA
Else
    CountThisItem = 0
End If
End Function

used in sub. function find all items so number of duplicates is- 1

Sub FindDuplicates()
Dim int_LastRow As Integer
Dim rng_WorkRange As Range
Dim str_Text As String

int_LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
Set rng_WorkRange = ActiveSheet.Range("A1:A" & int_LastRow)

For i = 1 To int_LastRow
    str_Text = ActiveSheet.Range("A" & i)
    ActiveSheet.Range("B" & i) = CountThisItem(rng_WorkRange, str_Text) - 1
Next i
End Sub