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