VBA other Duplicate id address

[KDS14589]

I have the following code to identify duplicates in Column “G” and identifies them in Column “K” with Duplicate RGB. But I want to go one step more and have the Row number of the other duplicate included with the Duplicate RGB, such as Duplicate RBG row 569

For row_data = row_data_start To row_data_last

On Error Resume Next



If Application.WorksheetFunction.CountIf(Ws.Range("G4:G500"), Ws.Range("G" & row_data)) > 1 Then

Ws.Range("K" & row_data).Value = "Duplicate RGB " '''''& Ws.Range("G" & row_data).Address > 1

Ws.Range("K" & row_data).Interior.Color = vbRed

Else

Ws.Range("K" & row_data).Value = ""

End If

Next row_data

 

[DanteAmor]

Try this:

Sub Duplicate_Rows()
  Dim c As Range, rng As Range, f As Range
  Dim cell As String, cad As String
  Dim sh As Worksheet
  
  Set sh = Sheets("Sheet1")   'Fit the name of your sheet
  Set rng = sh.Range("G4", sh.Range("G" & Rows.Count).End(3))
  rng.Offset(, 4).Clear
  
  For Each c In rng
    cad = ""
    Set f = rng.Find(c.Value, c, xlValues, xlWhole, , xlNext)
    If Not f Is Nothing Then
      cell = f.Address
      If cell <> c.Address Then
      
        'Check if there are 2 or more equal data
        Do
          If f.Row <> c.Row Then cad = cad & f.Row & ", "
          Set f = rng.FindNext(f)
        Loop While Not f Is Nothing And f.Address <> cell
        
        With sh.Range("K" & c.Row)
          .Value = "Duplicate RGB " & Left(cad, Len(cad) - 2)
          .Interior.Color = vbRed
        End With
        
      End If
    End If
  Next
End Sub

 

[KDS14589]

Try this:

Sub Duplicate_Rows()
  Dim c As Range, rng As Range, f As Range
  Dim cell As String, cad As String
  Dim sh As Worksheet
 
  Set sh = Sheets("Sheet1")   'Fit the name of your sheet
  Set rng = sh.Range("G4", sh.Range("G" & Rows.Count).End(3))
  rng.Offset(, 4).Clear
 
  For Each c In rng
    cad = ""
    Set f = rng.Find(c.Value, c, xlValues, xlWhole, , xlNext)
    If Not f Is Nothing Then
      cell = f.Address
      If cell <> c.Address Then
     
        'Check if there are 2 or more equal data
        Do
          If f.Row <> c.Row Then cad = cad & f.Row & ", "
          Set f = rng.FindNext(f)
        Loop While Not f Is Nothing And f.Address <> cell
       
        With sh.Range("K" & c.Row)
          .Value = "Duplicate RGB " & Left(cad, Len(cad) - 2)
          .Interior.Color = vbRed
        End With
       
      End If
    End If
  Next
End Sub

it works
THANKS

 

[DanteAmor]

Im glad to help you, thanks for the feedback.