VBA Dictionary trying to update code

[Stephen_IV]

The code that I have below counts how many duplicates there are, in this case there are 4. I am looking to modify it to show me how many values make up the 4 duplicates the ans should be 13. Any help would be appreciated. Thanks in advance

<style type="text/css">
table.tableizer-table {
font-size: 12px;
border: 1px solid #CCC;
font-family: Arial, Helvetica, sans-serif;
}
.tableizer-table td {
padding: 4px;
margin: 3px;
border: 1px solid #CCC;
}
.tableizer-table th {
background-color: #104E8B;
color: #FFF;
font-weight: bold;
}
</style>
<table class="tableizer-table">
<thead><tr class="tableizer-firstrow"><th>111</th></tr></thead><tbody>
<tr><td>111</td></tr>
<tr><td>111</td></tr>
<tr><td>222</td></tr>
<tr><td>222</td></tr>
<tr><td>222</td></tr>
<tr><td>333</td></tr>
<tr><td>444</td></tr>
<tr><td>555</td></tr>
<tr><td>555</td></tr>
<tr><td>777</td></tr>
<tr><td>777</td></tr>
<tr><td>777</td></tr>
<tr><td>777</td></tr>
<tr><td>777</td></tr>
</tbody></table>

Function HowManyMakeUpDupes(r As Range) As Long
Dim dic As New Dictionary
    For Each cell In r
        If Not dic.Exists(cell.Value) Then
            dic.Add cell.Value, 1
            Else
        dic.Item(cell.Value) = dic.Item(cell.Value) + 1
        End If
    Next
    For Each i In dic.Items
        If i > 1 Then
            HowManyMakeUpDupes = HowManyMakeUpDupes + 1
        End If
    Next
End Function

 

[Marcelo Branco]

Maybe...

Function TotalDupes(r As Range) As Long
    Dim dic As Object, rCell As Range, v As Variant


    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = vbTextCompare
    For Each rCell In r
        dic(rCell.Value) = dic(rCell.Value) + 1
    Next
    For Each v In dic.Items
        If v > 1 Then TotalDupes = TotalDupes + v
    Next v
End Function

M.

 

[Stephen_IV]

Marcelo! Beautiful! Thank you very much! Does exactly what I want! Thanks again!

 

[Marcelo Branco]

You are welcome. Glad to help

M.