[已解决]包含相同则填充红色

mate66

符合要求的单元格填充为红色。

最佳答案

月排行榜 / 总排行榜

大灰狼1976

2017-8-8 10:47

1. Sub aaa()
   
2. Dim i&, j&, rng As Range, s$, n&, k&, b As Boolean
   
3. Application.ScreenUpdating = False
   
4. Set rng = [b7].CurrentRegion
   
5. rng.Interior.Pattern = xlNone
   
6. For i = 1 To rng.Rows.Count - 1
   
7.   For j = 2 To rng.Columns.Count - 1
   
8.     If rng(i, j) <> "" Then
   
9.       n = rng(i, j)
   
10.       s = IIf(n = 0, 9, n - 1) & n & IIf(n = 9, 0, n + 1)
    
11.       For k = j - 1 To j + 1
    
12.         If rng(i + 1, k) <> "" Then If InStr(s, rng(i + 1, k)) Then b = True: Exit For
    
13.       Next k
    
14.       If b Then rng(i, j).Interior.Color = vbRed
    
15.       b = False
    
16.     End If
    
17.   Next j
    
18. Next i
    
19. Application.ScreenUpdating = True
    
20. End Sub

复制代码

跳转到最佳答案楼层

大灰狼1976

1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
2. If Target.Count > 1 Then Exit Sub
   
3. If Intersect([b7].CurrentRegion, Target) Is Nothing Then Exit Sub
   
4. If Intersect([b7].CurrentRegion, Target.Offset(1)) Is Nothing Then Exit Sub
   
5. Dim i&, r&, c&, b As Boolean
   
6. r = Target.Row
   
7. c = Target.Column
   
8. For i = c - 1 To c + 1
   
9.   If Cells(r + 1, i) = IIf(Target = 0, 9, Target - 1) Then b = True: Exit For
   
10.   If Cells(r + 1, i) = Target Then b = True: Exit For
    
11.   If Cells(r + 1, i) = IIf(Target = 9, 0, Target + 1) Then b = True: Exit For
    
12. Next i
    
13. If b Then Target.Interior.Color = vbRed
    
14. End Sub

复制代码

mate66

大灰狼1976 发表于 2017-8-8 10:19

你好，老师。
一个一个点慢。可否弄成不自动的，一次性全部把符合要求的标示红色。

大灰狼1976

1. Sub aaa()
   
2. Dim i&, j&, rng As Range, s$, n&, k&, b As Boolean
   
3. Application.ScreenUpdating = False
   
4. Set rng = [b7].CurrentRegion
   
5. rng.Interior.Pattern = xlNone
   
6. For i = 1 To rng.Rows.Count - 1
   
7.   For j = 2 To rng.Columns.Count - 1
   
8.     If rng(i, j) <> "" Then
   
9.       n = rng(i, j)
   
10.       s = IIf(n = 0, 9, n - 1) & n & IIf(n = 9, 0, n + 1)
    
11.       For k = j - 1 To j + 1
    
12.         If rng(i + 1, k) <> "" Then If InStr(s, rng(i + 1, k)) Then b = True: Exit For
    
13.       Next k
    
14.       If b Then rng(i, j).Interior.Color = vbRed
    
15.       b = False
    
16.     End If
    
17.   Next j
    
18. Next i
    
19. Application.ScreenUpdating = True
    
20. End Sub

复制代码