VBA to select the first duplicate value and rename it with new text in a range

[Latha]

Dim rng, cell As Range
d = 1
Set rng = wrkbk.Sheets(1).Range("A1:AP1")


For Each cell In rng
    If WorksheetFunction.CountIf(rng, cell.Value) > 1 Then
    cell.Interior.ColorIndex = 3
    End If
    d = d + 1
Next

The above code is coloring the duplicate values in range A1:AP1
But instead, i need only the next dupllcate value to be selected and clear its content and put some new value

Please help me.

 

[Kenneth Hobson]

That can be done but I fear that there could be problems. The problem is, what is this "some new value"? Each dup value would have to be unique.

The approach I would use would be to use the Range's Find method. It could check the column number of the first one found and then modify the others if found range's Cells.Count>1.

Of course Ideally, you would use the Change event or Data Validation to prevent duplicates.

 

[Latha]

we have 42 columns and last 6 columns has duplicate headers. thats from Ak:AP like the below


[TABLE="width: 384"]
<tbody>[TR]
[TD]xxxx[/TD]
[TD]yyyy[/TD]
[TD]zzzz[/TD]
[TD]xxxx[/TD]
[TD]yyyy[/TD]
[TD]zzzz[/TD]
[/TR]
</tbody>[/TABLE]


so i would like the second xxxx to be renamed to xxxx1 and yyyy to be renamed to yyyy1

 

[Latha]

could someone please help me on this pleaseeeee

 

[Kenneth Hobson]

Sub Main()
  Dim c As Range, cc As Range, r As Range, f As Range, i As Integer
  Set r = Range("A1:AP1")
  For Each c In r
    Set f = FoundRangesB(r, c.Value2, False)
    If Not f Is Nothing Then
      'Rename cells if needed
      i = 1
      For Each cc In f
        If Not c.Address = cc.Address Then
          cc.Value2 = cc.Value2 & i
          i = i + 1
        End If
      Next cc
    End If
  Next c
End Sub

Function FoundRangesB(fRange As Range, fStr As String, Optional tfBlanks As Boolean = True) As Range
    Dim objFind As Range
    Dim rFound As Range, FirstAddress As String
     
    If fStr = "" And tfBlanks = False Then
      Set FoundRangesB = Nothing
      Exit Function
    End If
     
    With fRange
        Set objFind = .Find(What:=fStr, after:=fRange.Cells((fRange.Rows.Count), fRange.Columns.Count), _
        LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
        SearchDirection:=xlPrevious, MatchCase:=True)
        If Not objFind Is Nothing Then
            Set rFound = objFind
            FirstAddress = objFind.Address
            Do
                Set objFind = .FindNext(objFind)
                If Not objFind Is Nothing Then Set rFound = Union(objFind, rFound)
            Loop While Not objFind Is Nothing And objFind.Address <> FirstAddress
        End If
    End With
    Set FoundRangesB = rFound
End Function