Remove Duplicates By Making Them Unique

[mbancrof]

I have a column which can contain several duplicates next to each other. Using VBA, I need to count them and make them unique by renaming them. Here's an example, say it's in Column B of Excel:

Docu0016.pdf
Docu0016.pdf
Docu0016.pdf
Docu0016.pdf
Docu0017.pdf
Docu0017.pdf
Docu0017.pdf
Docu0017.pdf

The macro would count the duplicates and make them unique by placing the count in parenthesis "()" at the end of the name. The results would look like this:

Docu0016.pdf
Docu0016(2).pdf
Docu0016(3).pdf
Docu0016(4).pdf
Docu0017.pdf
Docu0017(2).pdf
Docu0017(3).pdf
Docu0017(4).pdf

Any suggestions would be greatly appreciated!

[mbancrof]

Sub NumberDuplicates()
    Const TheCol = 2   ' Column 2 = column B
    Const FirstRow = 1 ' Start row
    Dim TheRow As Long
    Dim LastRow As Long
    Dim TheDict As Object
    Dim TheVal As String
    Dim ThePos As Long
    Set TheDict = CreateObject("Scripting.Dictionary")
    LastRow = Cells(Rows.Count, TheCol).End(xlUp).Row
    For TheRow = FirstRow To LastRow
        TheVal = Cells(TheRow, TheCol).Value
        If TheDict.Exists(TheVal) Then
            TheDict(TheVal) = TheDict(TheVal) + 1
            ThePos = InStrRev(TheVal, ".")
            Cells(TheRow, TheCol).Value = Left(TheVal, ThePos - 1) & "(" & TheDict(TheVal) & ")" & Mid(TheVal, ThePos)
        Else
            TheDict.Add Key:=TheVal, Item:=1
        End If
    Next TheRow
End Sub

[mana]

Sub test()


    Columns(3).Insert
    Columns(2).SpecialCells(xlCellTypeConstants).Offset(, 1).FormulaR1C1 = _
                "=RC[-1]&IF(COUNTIF(R1C1:RC[-1],RC[-1])>1,""(""&COUNTIF(R1C1:RC[-1],RC[-1])&"")"","""")"
    Columns(3).Copy
    Columns(2).PasteSpecial xlPasteValues
    Columns(3).Delete
    
End Sub

[mbancrof]

Thank you mana!!