OilEconomist
Active Member
- Joined
- Dec 26, 2016
- Messages
- 439
- Office Version
- 2019
- Platform
- 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:
I would like the cells to be renamed as follows:
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:
Where I could remove the
and the subsequent
, but could not figure out how.
Tried
, but that did not work.
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:
VBA Code:
aCell.Value = aCell.Value & "." & WorksheetFunction.CountIf(.Parent.Range(.Cells(3), aCell), aCell.Value & ".*")
Where I could remove the
VBA Code:
With Rng
VBA Code:
End With
Tried
VBA Code:
aCell.Value = aCell.Value & "." & WorksheetFunction.CountIf(Rng, aCell.Value & ".*")
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