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

[OilEconomist]

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
11	Dog
12	Cat
13	Dog
14	Dog
15	Bird
16	Cat
17	Dog
Sheet1

I would like the cells to be renamed as follows:

Book3
	C
11	Dog.01
12	Cat.01
13	Dog.02
14	Dog.03
15	Bird
16	Cat.02
17	Dog.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:

aCell.Value = aCell.Value & "." & WorksheetFunction.CountIf(.Parent.Range(.Cells(3), aCell), aCell.Value & ".*")

Where I could remove the

With Rng

and the subsequent

End With

, but could not figure out how.

Tried

aCell.Value = aCell.Value & "." & WorksheetFunction.CountIf(Rng, aCell.Value & ".*")

, but that did not work.

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

 

[Peter_SSs]

but it labels blank cells with 0s.

The importance of representative sample data - in which there were no blank cells!

as I can adjust that code as necessary

Both codes really only need adjusting to the relevant column and top cell of the range (though my code admittedly did not specify the worksheet)

for the helper column does it find the first blank column so it does not disturb anything else?

Yes

Anyway adjustment to my code that should produce all results at once without looping would be:

Sub CountThem_v2()
  Dim ws As Worksheet
  Dim oSet As Long
 
  Set ws = Sheets("Sheet1")
  With ws.Range("C11", ws.Range("C" & Rows.Count).End(xlUp))
    oSet = ws.Cells.Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column - .Column + 1
    .Offset(, oSet).FormulaR1C1 = Replace(Replace(Replace("=IF(RC[-#]="""","""",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

 

[OilEconomist]

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):

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

Thanks @Trebor76 this works, but I am going to mark @Alex Blakenburg's solution as correct since it worked for me from the beginning and yours is similar to his. Apologies about not including the blanks spaces, but I added that after my post. Will try to do better next time.

 

[OilEconomist]

The importance of representative sample data - in which there were no blank cells!


Both codes really only need adjusting to the relevant column and top cell of the range (though my code admittedly did not specify the worksheet)


Yes

Anyway adjustment to my code that should produce all results at once without looping would be:

Sub CountThem_v2()
  Dim ws As Worksheet
  Dim oSet As Long
 
  Set ws = Sheets("Sheet1")
  With ws.Range("C11", ws.Range("C" & Rows.Count).End(xlUp))
    oSet = ws.Cells.Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column - .Column + 1
    .Offset(, oSet).FormulaR1C1 = Replace(Replace(Replace("=IF(RC[-#]="""","""",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

Thanks @Peter_SSs this works, but I am going to mark @Alex Blakenburg's solution as correct since it worked for me from the beginning. Apologies about not including the blanks spaces, but I added that after my post. Will try to do better next time.