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!!