Duplicating cells with address in excel - excel

Question

I am having 10 columns from B to L in excel. I want to check for duplicates within this Range. But I want to know which cell is duplicating with another cell(need a reference of parent one). Please help me to arrive the solution. Here is the code which i tried to solve by getting the "comment with cell address". It is incomplete.
Please suggest best way for this problem.
Thanks in advance.
here is my code
Sub bomstruct()
Dim i As Long
Dim j As Long
Dim f As Long
Dim k As Integer
Dim w As Integer
Range("A3").Select
f = Range(Selection, Selection.End(xlDown)).Rows.Count
Dim Cval As Variant
For k = 3 To f
Cells(k, j).Activate
Cval = Cells(k, j).Value
Cadd = Cells(k, j).Address
If Cval = "" Then
Else
For j = 2 To 12
Cells(i, j).Select
g = f + 3
For i = 790 To g
If i = g Then
Cells(i - g + 3, j + 1).Select
Else
Cells(i, j).Select
If ActiveCell.Value = Cval Then
ActiveCell.Interior.ColorIndex = 6
ActiveCell.AddComment (Cadd)
End If
End If
Next i
i = i - g + 3
Next j
End If
Next k
End Sub

Answer 1

Following code checks for all duplicates and marks (comment and color) the duplicates. It ignores empty cells:
Sub callIt()
Dim rng As Range
' Set the range to check
With ActiveSheet
Set rng = .Range(.Range("A3"), .Range("A3").End(xlDown)).Offset(0, 1).Resize(, 11)
End With
' ===== MAYBE NEEDED ==================================
' Remove color
rng.Interior.colorIndex = 0
' Remove comment if there is one
rng.ClearComments
' ======================================================
' Call the function with the range set
colorizeAndCommentDuplicates rng
End Sub
' Colorize duplicates (same .value) in a range and add comment showing the addresses
' of all duplicates found. Ignores empty cells.
' Args:
' rng (Range): Range to check for duplicates
Sub colorizeAndCommentDuplicates(rng As Range)
Dim rngValuesArray As Variant
Dim i As Long, j As Long
Dim currentValue As Variant
Dim dict As Object, dictDuplicates As Object, rngDuplicates As Range
' Create dict to store ranges
Set dict = CreateObject("Scripting.Dictionary")
Set dictDuplicates = CreateObject("Scripting.Dictionary")
' Write range values into array
rngValuesArray = rng.value
' Loop through range array and find duplicates
For i = LBound(rngValuesArray, 1) To UBound(rngValuesArray, 1)
For j = LBound(rngValuesArray, 2) To UBound(rngValuesArray, 2)
currentValue = rngValuesArray(i, j)
' Skip empty cells
If currentValue <> vbNullString Then
' Only check for duplicates of value if we not already have
If Not dict.exists(currentValue) Then
dict(currentValue) = True
Set rngDuplicates = getDuplicatesRanges(currentValue, rngValuesArray, rng(1))
' Check if duplicates found
If Not rngDuplicates Is Nothing Then
' Add ranges of duplicates to dict
Set dictDuplicates(currentValue) = rngDuplicates
End If
End If
End If
Next
Next
' colorize and add comments
markDuplicates dictDuplicates
End Sub
' Check for duplicates in range values array and return range with duplicates
' if duplicates exist or nothing if there are no duplicates.
' Args:
' valuetoCheck (Variant): Look for duplicates of value.
' rngValuesArray (Variant): Array holding values of a range
' to look for duplicates of value in.
' rngTopLeft (Range): First (top left) range of range to look
' for duplicates in.
' Returns:
' (Range) Nothing if no duplicate found else Range (Areas) of
' duplicates found.
Function getDuplicatesRanges(ByVal valueToCheck As Variant, _
ByVal valuesArray As Variant, ByVal rngTopLeft As Range) As Range
Dim rng As Range, rngTemp As Range
Dim arrayDuplicates() As String
Dim i As Long
Dim j As Long
Dim dictDuplicates
ReDim arrayDuplicates(0)
For i = LBound(valuesArray, 1) To UBound(valuesArray, 1)
For j = LBound(valuesArray, 2) To UBound(valuesArray, 2)
' Value found
If valueToCheck = valuesArray(i, j) Then
If arrayDuplicates(0) <> "" Then
ReDim Preserve arrayDuplicates(UBound(arrayDuplicates) + 1)
End If
arrayDuplicates(UBound(arrayDuplicates)) = i & "," & j
End If
Next
Next
' Loop through array with indexes of duplicates if any found
' and convert to range
If UBound(arrayDuplicates) > 0 Then
For i = 0 To UBound(arrayDuplicates)
Set rngTemp = rngTopLeft.Offset( _
Split(arrayDuplicates(i), ",")(0) - 1, _
Split(arrayDuplicates(i), ",")(1) - 1)
If rng Is Nothing Then
Set rng = rngTemp
Else
Set rng = Application.Union(rng, rngTemp)
End If
Next
Set getDuplicatesRanges = rng
End If
End Function
' Colorize and add comment to duplicates
' Args:
' dict (Object): Scripting dictionary holding values that have
' duplicates as key and all ranges of the duplictaes as values.
Sub markDuplicates(ByRef dict As Object)
Dim key As Variant
Dim rngDict As Range
Dim rng As Range
Dim addresses As String
' Loop through duplicates
For Each key In dict.keys
Set rngDict = dict(key)
' Create string with addresses
For Each rng In rngDict
If addresses <> vbNullString Then addresses = addresses & vbCrLf
addresses = addresses & rng.Address
Next
' Colorize and add comment
For Each rng In rngDict
rng.Interior.colorIndex = 6
rng.ClearComments
rng.AddComment addresses
Next
addresses = vbNullString
Next
End Sub

Answer 2

Highlighting the cells that are duplicate with a conditional formatting rule is one method of 'any other ways to identify'.
with worksheets("sheet1")
with .range("B:L")
With .FormatConditions
.Delete
.Add Type:=xlExpression, Formula1:="=COUNTIF($B:$L, B1)>1"
End With
With .FormatConditions(.FormatConditions.Count)
.Interior.Color = vbRed
End With
end with
end with

Answer 3

Here is a macro that will add a comment to each cell listing the addresses of all the duplicates.
Read the notes in the code.
I use a dictionary to detect the duplicates, and each item in the dictionary is a collection of cell addresses where those duplicates can be found.
As written it is "sorted by rows", but you can easily change the looping to sort by columns if you prefer.
The cell with the comment is excluded from the list of duplicates.
Option Explicit
Sub foo()
Dim d1 As Object, col As Collection
Dim v As Variant, w As Variant
Dim i As Long, j As Long
Dim S As String, sComment As String
Dim R As Range, C As Range
Set d1 = CreateObject("Scripting.Dictionary")
d1.CompareMode = TextCompare
'many ways to set bounds of the region to be processed
With Cells(2, 2).CurrentRegion
.ClearComments
v = .Value2 'read values into array for faster processing
End With
'collect the addresses of each value
For i = 1 To UBound(v, 1)
For j = 1 To UBound(v, 2)
If Not d1.exists(v(i, j)) Then
Set col = New Collection
'offset from array index to cell address depends on starting point of array
col.Add Cells(i + 1, j + 1).Address
d1.Add Key:=v(i, j), Item:=col
Else
d1(v(i, j)).Add Cells(i + 1, j + 1).Address
End If
Next j
Next i
'Add the comments
Cells(2, 2).CurrentRegion.ClearComments
For Each v In d1
If d1(v).Count > 1 Then
sComment = ""
S = d1(v)(1)
Set R = Range(S)
For i = 1 To d1(v).Count
S = d1(v)(i)
Set R = Union(R, Range(S))
sComment = sComment & "," & Range(S).Address
Next i
For Each C In R
'Exclude current cell from list of duplicates
S = Mid(Replace(sComment, "," & C.Address, ""), 2)
C.AddComment "Duplicates in" & vbLf & S
Next C
End If
Next v
End Sub