Question

我有以下代码，它突出显示在具有不同颜色的单个列中具有相同内容的连续和非连续单元格。是否可以修改此代码以突出显示一列中的仅连续单元格（例如黄色）？

Sub HighlightSameValues()
Dim rngArea As Range
Dim rngCellA As Range
Dim rngCellB As Range
Dim colValue As New Collection
Dim intColor As Integer  
Set rngArea = ActiveSheet.Range("F1:F65536")
intColor = 5
On Error Resume Next
For Each rngCellA In rngArea
If rngCellA.Value <> "" Then
Err.Clear
colValue.Add rngCellA.Value, "MB" & rngCellA.Value
If Err = 0 Then
intColor = intColor + 1
For Each rngCellB In rngArea
If rngCellB.Value = rngCellA.Value Then
rngCellB.Interior.ColorIndex = intColor
End If
Next rngCellB
End If
End If
Next rngCellA
End Sub

非常感谢对此事的协助。提前谢谢。

Answer 1

以下代码将突出显示B到F列中所有单元格的所有非空白和重复值：

Sub HighlightSameValues()
Dim rngArea As Range
Dim rngCellA As Range
Dim rngCellB As Range

    'Narrow the search area to only that which has been used
    Set rngArea = Intersect(ActiveSheet.UsedRange, ActiveSheet.Range("B:F"))

    For Each rngCellA In rngArea

        'No point in searching for blank cells or ones that have already been highlighted
        If Not rngCellA.Value = vbNullString And Not rngCellA.Interior.Color = vbYellow Then

            Set rngCellB = rngArea.Find(What:=rngCellA.Value, LookAt:=xlWhole, After:=rngCellA)

            'Check if the value in rngCellA exists anywhere else
            If Not rngCellB Is Nothing And Not rngCellB.Address = rngCellA.Address Then

                'If another does exist, highlight it and every value that duplicates it
                rngCellA.Interior.Color = vbYellow
                Do While Not rngCellB.Address = rngCellA.Address
                    rngCellB.Interior.Color = vbYellow
                    Set rngCellB = rngArea.Find(What:=rngCellA.Value, LookAt:=xlWhole, After:=rngCellB)
                Loop

            End If
        End If
    Next rngCellA
End Sub

要仅评估同一列中的连续单元格，我会修改代码：

Sub HighlightSameValues()
Dim rngArea As Range
Dim rngCellA As Range

    'Narrow the search area to only that which has been used
    Set rngArea = Intersect(ActiveSheet.UsedRange, ActiveSheet.Range("B:F"))

    For Each rngCellA In rngArea

        'No point in searching for blank cells or ones that have already been highlighted
        If Not rngCellA.Value = vbNullString And Not rngCellA.Interior.Color = vbYellow Then
            If rngCellA.Offset(-1, 0).Value = rngCellA.Value Then
                rngCellA.Offset(-1, 0).Interior.Color = vbYellow
                rngCellA.Interior.Color = vbYellow
            End If
            If rngCellA.Offset(1, 0).Value = rngCellA.Value Then
                rngCellA.Offset(1, 0).Interior.Color = vbYellow
                rngCellA.Interior.Color = vbYellow
            End If
        End If
    Next rngCellA
End Sub

这就是凌晨2点的编码让你无法入睡。 =）

我错过了所有重要的不在（不是rngCellA.Interior.Color = vbYellow）。另外我注意到我忘了突出显示的第一个细胞。

我已经重新测试了两个代码段，两者现在都按预期工作了。

段1将突出显示在列B到F中重复的任何内容。

第2段将突出显示仅在连续且位于同一列中的重复内容。

如果您的数据表从第1行开始（无标题）或转到工作表上的最后一行：

If Not rngCellA.Row = 1 Then
    If rngCellA.Offset(-1, 0).Value = rngCellA.Value Then
        rngCellA.Offset(-1, 0).Interior.Color = vbYellow
        rngCellA.Interior.Color = vbYellow
    End If
End If
If Not rngCellA.Row = ActiveSheet.Rows.Count Then
    If rngCellA.Offset(1, 0).Value = rngCellA.Value Then
        rngCellA.Offset(1, 0).Interior.Color = vbYellow
        rngCellA.Interior.Color = vbYellow
    End If
End If

vba代码仅突出显示一列中的连续重复项

1 个答案: