[已解决]按要求填充红色

mate33

按要求填充红色

最佳答案

月排行榜 / 总排行榜

grf1973

2017-4-21 08:50

选择后再点击按钮。

1. Sub tt()
   
2.     Dim rng As Range
   
3.     ActiveSheet.UsedRange.Cells.Interior.ColorIndex = 0
   
4.     If Selection.Rows.Count = 1 Then MsgBox "选择范围必须大于1行": Exit Sub
   
5.     If Selection.Columns.Count < 6 Then MsgBox "选择范围不能小于6列": Exit Sub
   
6.     arr = Selection
   
7.     Set rng = Selection(1) '左上位置
   
8.     On Error Resume Next     '容错，超过边界
   
9.     For i = 2 To UBound(arr)
   
10.         x = arr(i, 1): y = arr(i, 2): Z = arr(i, 3)
    
11.         rng.Offset(i - 1).Resize(1, 3).Interior.ColorIndex = 6   '对比数，标注黄色
    
12.         For j = 4 To UBound(arr, 2) Step 3
    
13.             xyz = ""
    
14.             xyz = arr(i - 1, j) & arr(i - 1, j + 1) & arr(i - 1, j + 2)
    
15.             If InStr(xyz, x) Or InStr(xyz, y) Or InStr(xyz, Z) Then
    
16.                 rng.Offset(i - 2, j - 1).Resize(1, 3).Interior.ColorIndex = 3       '符合条件的，标注红色
    
17.             End If
    
18.         Next
    
19.     Next
    
20. End Sub
    

复制代码

跳转到最佳答案楼层

grf1973

1. Sub tt()
   
2.     Dim rng As Range
   
3.     ActiveSheet.UsedRange.Cells.Interior.ColorIndex = 0
   
4.     Set rng = Application.InputBox("请点选区域", "范围", , , , , , 8)
   
5.     If rng.Rows.Count = 1 Then MsgBox "选择范围必须大于1行": Exit Sub
   
6.     If rng.Columns.Count < 6 Then MsgBox "选择范围不能小于6列": Exit Sub
   
7.     arr = rng
   
8.     Set rng = rng(1) '左上位置
   
9.     On Error Resume Next     '容错，超过边界
   
10.     For i = 2 To UBound(arr)
    
11.         x = arr(i, 1): y = arr(i, 2): Z = arr(i, 3)
    
12.         rng.Offset(i - 1).Resize(1, 3).Interior.ColorIndex = 6   '对比数，标注黄色
    
13.         For j = 4 To UBound(arr, 2) Step 3
    
14.             xyz = ""
    
15.             xyz = arr(i - 1, j) & arr(i - 1, j + 1) & arr(i - 1, j + 2)
    
16.             If InStr(xyz, x) Or InStr(xyz, y) Or InStr(xyz, Z) Then
    
17.                 rng.Offset(i - 2, j - 1).Resize(1, 3).Interior.ColorIndex = 3       '符合条件的，标注红色
    
18.             End If
    
19.         Next
    
20.     Next
    
21. End Sub
    

复制代码

mate33

grf1973 发表于 2017-4-19 15:30

老师你好，可否先自行先选择区域，然后再运行VBA的。
数据区域在A1:Z1000。

grf1973

选择后再点击按钮。

1. Sub tt()
   
2.     Dim rng As Range
   
3.     ActiveSheet.UsedRange.Cells.Interior.ColorIndex = 0
   
4.     If Selection.Rows.Count = 1 Then MsgBox "选择范围必须大于1行": Exit Sub
   
5.     If Selection.Columns.Count < 6 Then MsgBox "选择范围不能小于6列": Exit Sub
   
6.     arr = Selection
   
7.     Set rng = Selection(1) '左上位置
   
8.     On Error Resume Next     '容错，超过边界
   
9.     For i = 2 To UBound(arr)
   
10.         x = arr(i, 1): y = arr(i, 2): Z = arr(i, 3)
    
11.         rng.Offset(i - 1).Resize(1, 3).Interior.ColorIndex = 6   '对比数，标注黄色
    
12.         For j = 4 To UBound(arr, 2) Step 3
    
13.             xyz = ""
    
14.             xyz = arr(i - 1, j) & arr(i - 1, j + 1) & arr(i - 1, j + 2)
    
15.             If InStr(xyz, x) Or InStr(xyz, y) Or InStr(xyz, Z) Then
    
16.                 rng.Offset(i - 2, j - 1).Resize(1, 3).Interior.ColorIndex = 3       '符合条件的，标注红色
    
17.             End If
    
18.         Next
    
19.     Next
    
20. End Sub
    

复制代码