VBA Code to Find Duplicate Values in a Range and Add a Number at the End

O

OilEconomist

Active Member
Joined
Dec 26, 2016
Messages
439
Office Version
  1. 2019
Platform
  1. Windows
Thanks in advance for your assistance.

What is the MS Excel VBA Code to check a pre-defined range (a column with x rows of data) to see if there are any duplicates values and if so rename them with the instance.

So for example if the data was as follows:
Book3
C
11Dog
12Cat
13Dog
14Dog
15Bird
16Cat
17Dog
Sheet1


I would like the cells to be renamed as follows:
Book3
C
11Dog.01
12Cat.01
13Dog.02
14Dog.03
15Bird
16Cat.02
17Dog.04
Sheet1


One important point is that if it were to reach instances of 10 or more of something like "Dog" it would not have a 0 in front of it.

So if there were 10 instances of Dog, the 10th instance would be renamed "Dog.10"
or if there were 11 instances of Dog, the 11th instance would be renamed "Dog.11"

I found a code similar to what I was seeking: VBA: find duplicates and change, but for the first instance of a duplicate it does not rename it.

I also found one that might be a bit more efficient since it uses a Scripting Dictionary, but could not quite follow it: Find a duplicate value in the column using VBA code

Here is my code thus far. It works, with the exception of re-naming the first instance of a duplicate.

Also I was attempting to change the line:
VBA Code: 
aCell.Value = aCell.Value & "." & WorksheetFunction.CountIf(.Parent.Range(.Cells(3), aCell), aCell.Value & ".*")

Where I could remove the
VBA Code: 
With Rng
and the subsequent
VBA Code: 
End With
, but could not figure out how.

Tried
VBA Code: 
aCell.Value = aCell.Value & "." & WorksheetFunction.CountIf(Rng, aCell.Value & ".*")
, but that did not work.

VBA Code: 
Option Explicit

Sub FindandReplace()
    
    'Dimensioning
     Dim RL As Long, RS As Long
     Dim CN_NmRngs As Long
     Dim ShtNm As String
    
     Dim aCell As Range, Rng As Range
    

 '_________________________________________________________________________________________________
 'Turn off alerts, and screen UDs
     
     Application.ScreenUpdating = False
     Application.DisplayAlerts = False

 
 '_________________________________________________________________________________________________
 'Settings
    
    'Sheet Name
     ShtNm = "Sheet1"
     
    'Column no.
     CN_NmRngs = 3
     
     
    'Row start
     RS = 11

 '_________________________________________________________________________________________________
 'Code - find last row and set range
    
    'Last row
     RL = Cells(Rows.Count, CN_NmRngs).End(xlUp).Row
     
    
    'Set Range
     With Sheets(ShtNm)
        Set Rng = .Range(.Cells(RS, CN_NmRngs), .Cells(RL, CN_NmRngs))
     End With
     
    
 '_________________________________________________________________________________________________
 'Code - rename duplicates
    
    
    With Worksheets("Sheet1")
        With Rng
            For Each aCell In Rng
                If aCell <> "" Then
                    aCell.Value = aCell.Value & "." & WorksheetFunction.CountIf(.Parent.Range(.Cells(3), aCell), aCell.Value & ".*")
                End If
            Next aCell
            
            For Each aCell In .Cells
                If Right(aCell, 2) = ".0" Then
                    .Replace what:=".0", replacement:="", lookat:=xlPart
                End If
            Next aCell
            
        End With
    End With

 
 '_________________________________________________________________________________________________
 'Turn on alerts, and screen UDs
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    


 '_________________________________________________________________________________________________
 'End of Sub
  
    

End Sub
 

Excel Facts

Highlight Duplicates
Home, Conditional Formatting, Highlight Cells, Duplicate records, OK to add pink formatting to any duplicates in selected range.
Sort by date Sort by votes
Hi there,

Try this:

VBA Code: 
Option Explicit
Sub Macro1()

    Dim lngLastRow As Long, i As Long, j As Long
    Dim ws As Worksheet
    Dim rngCell As Range
    Dim strKey As String
    Dim objDict As Object
    
    Application.ScreenUpdating = False
    
    Set ws = ThisWorkbook.Sheets("Sheet1")
    lngLastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
    Set objDict = CreateObject("Scripting.Dictionary")
    
    For Each rngCell In ws.Range("A2:A" & lngLastRow)
        j = Application.WorksheetFunction.CountIf(ws.Range("A2:A" & lngLastRow), rngCell)
        If j >= 2 Then
            For i = 1 To j
                strKey = IIf(i < 10, rngCell.Value & ".0" & i, rngCell.Value & "." & i)
                If Not objDict.Exists(strKey) Then
                    objDict.Add strKey, i
                    Exit For
                End If
            Next i
        Else
            objDict.Add CStr(rngCell), 1
        End If
    Next rngCell
    
    ws.Range("A2:A" & lngLastRow).Value = Application.Transpose(Array(objDict.Keys))
    
    Application.ScreenUpdating = True

End Sub
 
Upvote 1
Trebor76 said:
Hi there,

Try this:

VBA Code: 
Option Explicit
Sub Macro1()

    Dim lngLastRow As Long, i As Long, j As Long
    Dim ws As Worksheet
    Dim rngCell As Range
    Dim strKey As String
    Dim objDict As Object
   
    Application.ScreenUpdating = False
   
    Set ws = ThisWorkbook.Sheets("Sheet1")
    lngLastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
    Set objDict = CreateObject("Scripting.Dictionary")
   
    For Each rngCell In ws.Range("A2:A" & lngLastRow)
        j = Application.WorksheetFunction.CountIf(ws.Range("A2:A" & lngLastRow), rngCell)
        If j >= 2 Then
            For i = 1 To j
                strKey = IIf(i < 10, rngCell.Value & ".0" & i, rngCell.Value & "." & i)
                If Not objDict.Exists(strKey) Then
                    objDict.Add strKey, i
                    Exit For
                End If
            Next i
        Else
            objDict.Add CStr(rngCell), 1
        End If
    Next rngCell
   
    ws.Range("A2:A" & lngLastRow).Value = Application.Transpose(Array(objDict.Keys))
   
    Application.ScreenUpdating = True

End Sub
Click to expand...
Thanks @Trebor76 for the quick response. One thing to note is the data is in column C and starts C11 (Column number marked as 3 and start row is designated as 11). I tried to modify the code to adjust for this, but then I get the error " Run-time error '457': This key is already associated with an element of this collection" on the following line:
VBA Code: 
objDict.Add CStr(rngCell), 1

Here is the code as I modified it to suite that it was in column C and not A.

VBA Code: 
Option Explicit
Sub Macro1()

    Dim lngLastRow As Long, i As Long, j As Long
    Dim ws As Worksheet
    Dim rngCell As Range
    Dim strKey As String
    Dim objDict As Object
    
    Application.ScreenUpdating = False
    
    Set ws = ThisWorkbook.Sheets("Sheet1")
    lngLastRow = ws.Cells(Rows.Count, "C").End(xlUp).Row
    Set objDict = CreateObject("Scripting.Dictionary")
    
    For Each rngCell In ws.Range("C11:C" & lngLastRow)
        j = Application.WorksheetFunction.CountIf(ws.Range("C11:C" & lngLastRow), rngCell)
        If j >= 2 Then
            For i = 1 To j
                strKey = IIf(i < 10, rngCell.Value & ".0" & i, rngCell.Value & "." & i)
                If Not objDict.Exists(strKey) Then
                    objDict.Add strKey, i
                    Exit For
                End If
            Next i
        Else
            objDict.Add CStr(rngCell), 1
        End If
    Next rngCell
    
    ws.Range("C11:C" & lngLastRow).Value = Application.Transpose(Array(objDict.Keys))
    
    Application.ScreenUpdating = True

End Sub
 
Upvote 0
OilEconomist said:
Thanks @Trebor76 for the quick response. One thing to note is the data is in column C and starts C11 (Column number marked as 3 and start row is designated as 11). I tried to modify the code to adjust for this, but then I get the error " Run-time error '457': This key is already associated with an element of this collection" on the following line:
VBA Code: 
objDict.Add CStr(rngCell), 1

Here is the code as I modified it to suite that it was in column C and not A.

VBA Code: 
Option Explicit
Sub Macro1()

    Dim lngLastRow As Long, i As Long, j As Long
    Dim ws As Worksheet
    Dim rngCell As Range
    Dim strKey As String
    Dim objDict As Object
   
    Application.ScreenUpdating = False
   
    Set ws = ThisWorkbook.Sheets("Sheet1")
    lngLastRow = ws.Cells(Rows.Count, "C").End(xlUp).Row
    Set objDict = CreateObject("Scripting.Dictionary")
   
    For Each rngCell In ws.Range("C11:C" & lngLastRow)
        j = Application.WorksheetFunction.CountIf(ws.Range("C11:C" & lngLastRow), rngCell)
        If j >= 2 Then
            For i = 1 To j
                strKey = IIf(i < 10, rngCell.Value & ".0" & i, rngCell.Value & "." & i)
                If Not objDict.Exists(strKey) Then
                    objDict.Add strKey, i
                    Exit For
                End If
            Next i
        Else
            objDict.Add CStr(rngCell), 1
        End If
    Next rngCell
   
    ws.Range("C11:C" & lngLastRow).Value = Application.Transpose(Array(objDict.Keys))
   
    Application.ScreenUpdating = True

End Sub
Click to expand...
That’s odd as when the countif equals one it should be unique.

I’m out now for a few hours but maybe if you can post your actual data someone will be able to help or I’ll look later.
 
Upvote 1
I'm not sure what is causing the error you are getting but since I think Robert's inner loop is doing a quite a bit of unnecessary work here is another option.

VBA Code: 
Sub AddUniqueID()

    Dim ws As Worksheet
    Dim lastRow As Long, i As Long, iCnt As Long, idxArr As Long
    Dim rng As Range, arr As Variant
    Dim dict As Object, dictKey As String
  
    Set ws = Worksheets("Sheet1")                           ' Change to your sheet name
    With ws
        lastRow = .Cells(Rows.Count, "C").End(xlUp).Row
        Set rng = .Range("C11", .Cells(lastRow, "C"))
        arr = rng.Value
    End With

    Set dict = CreateObject("Scripting.dictionary")
    dict.CompareMode = vbTextCompare
     
    For i = 1 To UBound(arr)
        dictKey = arr(i, 1)
        If Not dict.exists(dictKey) Then
            dict(dictKey) = -i                                              ' for 1st occurence store array index no as a negative value
        Else
            iCnt = dict(dictKey)
            If iCnt < 0 Then
                ' go back and update 1st occurence
                iCnt = 1
                idxArr = Abs(dict(dictKey))                                 ' convert negative array index no back to positive va.ue
                arr(idxArr, 1) = arr(idxArr, 1) & "." & Format(iCnt, "00")
            End If
            iCnt = iCnt + 1
            arr(i, 1) = arr(i, 1) & "." & Format(iCnt, "00")
            dict(dictKey) = iCnt
        End If
    Next i
  
    rng.Value = arr

End Sub
 
Upvote 1
Solution
My suggestion finds a vacant column at the right of any other data on the worksheet and uses that column as a helper.

VBA Code: 
Sub CountThem()
  Dim oSet As Long
  
  With Range("C11", Range("C" & Rows.Count).End(xlUp))
    oSet = Cells.Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column - .Column + 1
    .Offset(, oSet).FormulaR1C1 = Replace(Replace(Replace("=RC[-#]&IF(COUNTIF(R^C[-#]:R@C[-#],RC[-#])=1,"""",TEXT(COUNTIF(R^C[-#]:RC[-#],RC[-#]),""\.00""))", "#", oSet), "^", .Row), "@", .Row + .Rows.Count - 1)
    .Value = .Offset(, oSet).Value
    .Offset(, oSet).ClearContents
  End With
End Sub
 
Last edited:
Upvote 1
Alex Blakenburg said:
I'm not sure what is causing the error you are getting but since I think Robert's inner loop is doing a quite a bit of unnecessary work here is another option.

VBA Code: 
Sub AddUniqueID()

    Dim ws As Worksheet
    Dim lastRow As Long, i As Long, iCnt As Long, idxArr As Long
    Dim rng As Range, arr As Variant
    Dim dict As Object, dictKey As String
 
    Set ws = Worksheets("Sheet1")                           ' Change to your sheet name
    With ws
        lastRow = .Cells(Rows.Count, "C").End(xlUp).Row
        Set rng = .Range("C11", .Cells(lastRow, "C"))
        arr = rng.Value
    End With

    Set dict = CreateObject("Scripting.dictionary")
    dict.CompareMode = vbTextCompare
    
    For i = 1 To UBound(arr)
        dictKey = arr(i, 1)
        If Not dict.exists(dictKey) Then
            dict(dictKey) = -i                                              ' for 1st occurence store array index no as a negative value
        Else
            iCnt = dict(dictKey)
            If iCnt < 0 Then
                ' go back and update 1st occurence
                iCnt = 1
                idxArr = Abs(dict(dictKey))                                 ' convert negative array index no back to positive va.ue
                arr(idxArr, 1) = arr(idxArr, 1) & "." & Format(iCnt, "00")
            End If
            iCnt = iCnt + 1
            arr(i, 1) = arr(i, 1) & "." & Format(iCnt, "00")
            dict(dictKey) = iCnt
        End If
    Next i
 
    rng.Value = arr

End Sub
Click to expand...
Thanks so much @Alex Blakenburg as your solution works. The only change I made was adding the following if then statement so it did not label/number blank cells:
VBA Code: 
If dictKey <> ""

after:
VBA Code: 
dictKey = arr(i, 1)

and adding the subsequent end if
VBA Code: 
End If

before the line:
VBA Code: 
Next i

​

 
Upvote 0
Peter_SSs said:
My suggestion finds a vacant column at the right of any other data on the worksheet and uses that column as a helper.

VBA Code: 
Sub CountThem()
  Dim oSet As Long
 
  With Range("C11", Range("C" & Rows.Count).End(xlUp))
    oSet = Cells.Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column - .Column + 1
    .Offset(, oSet).FormulaR1C1 = Replace(Replace(Replace("=RC[-#]&IF(COUNTIF(R^C[-#]:R@C[-#],RC[-#])=1,"""",TEXT(COUNTIF(R^C[-#]:RC[-#],RC[-#]),""\.00""))", "#", oSet), "^", .Row), "@", .Row + .Rows.Count - 1)
    .Value = .Offset(, oSet).Value
    .Offset(, oSet).ClearContents
  End With
End Sub
Click to expand...
Thanks @Peter_SSs as this seems to also work, but it labels blank cells with 0s. Also, @Alex Blakenburg 's solution is probably closer to what I am seeking as I can adjust that code as necessary and probably will make a function out of it.

One more question, for the helper column does it find the first blank column so it does not disturb anything else?
 
Upvote 0
Though Alex's and Peter's are the way to go the reason why code errored out was because of the blank cells you must have in Col. C as the COUNTIF function returns zero for each one.

This amended version will do the job (it did for me):

VBA Code: 
Option Explicit
Sub Macro1()

    Dim lngLastRow As Long, i As Long, j As Long, k As Long
    Dim ws As Worksheet
    Dim rngCell As Range
    Dim strKey As String, strArr() As String
    Dim objDict As Object
    
    Application.ScreenUpdating = False
    
    Set ws = ThisWorkbook.Sheets("Sheet1")
    lngLastRow = ws.Cells(Rows.Count, "C").End(xlUp).Row
    Set objDict = CreateObject("Scripting.Dictionary")
    
    For Each rngCell In ws.Range("C11:C" & lngLastRow)
        i = i + 1
        If Len(rngCell) = 0 Then
            ReDim Preserve strArr(1 To i)
            strArr(i) = rngCell
        Else
            k = Application.WorksheetFunction.CountIf(ws.Range("C11:C" & lngLastRow), rngCell)
            If k >= 2 Then
                For j = 1 To k
                    strKey = IIf(j < 10, rngCell.Value & ".0" & j, rngCell.Value & "." & j)
                    If Not objDict.Exists(strKey) Then
                        objDict.Add strKey, k
                        ReDim Preserve strArr(1 To i)
                        strArr(i) = strKey
                        Exit For
                    End If
                Next j
            Else
                objDict.Add CStr(rngCell), 1
                ReDim Preserve strArr(1 To i)
                strArr(i) = rngCell
            End If
        End If
    Next rngCell
    
    ws.Range("C11:C" & lngLastRow).Value = Application.Transpose(strArr)
    
    Application.ScreenUpdating = True

End Sub
 
Upvote 1
You must log in or register to reply here.

Similar threads

S
  • Solved
Delete Row if value in column C is a duplicate
Replies
8
Views
174
igold
igold
Young Grasshopper
  • Solved
"If Me.ComboBox1.Value =" - Problem
Replies
3
Views
2K
Young Grasshopper
Young Grasshopper
O
  • Question
Change MS Word Doc Properties via MS Excel VBA Macro
Replies
3
Views
525
NdNoviceHlp
NdNoviceHlp
A
  • Question
Error Handling
Replies
7
Views
158
6StringJazzer
6StringJazzer
T
  • Solved
Duplicate and rename a sheet based on a cell text
Replies
3
Views
548
skillilea
S

Forum statistics

Threads
1,221,310
Messages
6,159,173
Members
451,543
Latest member
cesymcox

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top