vba代码只突出显示一列中的连续副本

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

下面的代码将突出所有非空和至F在B柱重复值对于所有小区：

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点的编码让你没有睡眠。 =）

我错过了所有重要的Not in（不是rngCellA.Interior.Color = vbYellow）。另外我注意到，我忘记强调第一个确定的细胞。

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

段1将突出任何通过F.

段2 B柱内重复将突出任何只复制是连续的且在同一列中。

如果你的数据表中的行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