我在Excel中从B到L有10列。我要检查此范围内的重复项。但是我想知道哪个单元格正在与另一个单元格重复（需要父级单元格的引用）。请帮助我到达解决方案。这是我尝试通过获取“带有单元格地址的注释”来解决的代码。它是不完整的。
请提出解决此问题的最佳方法。
谢谢。
这是我的代码
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
答案 0 :(得分：0)
使用条件格式设置规则突出显示重复的单元格是“任何其他标识方式”的一种方法。
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
答案 1 :(得分：0)
这里是一个宏，它将在每个单元格中添加注释，列出所有重复项的地址。
阅读代码中的注释。
我使用字典来检测重复项，字典中的每个项目都是一个单元格地址的集合，可以在其中找到这些重复项。
如前所述，它是“按行排序”的，但是您可以根据需要轻松地将循环更改为按列排序。
带有注释的单元格从重复项列表中排除。
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
答案 2 :(得分：0)
以下代码检查所有重复项并标记重复项（注释和颜色）。它会忽略空单元格：
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