[已解决]填色2（填色1的升级）!

wszbd

eaglexs 发表于 2014-1-26 15:12
原始的数据在EU1:EW2间没有文字数据，我用range("eu3").currentregion就能把ET3:EW12之间的数据包括起来。 ...

你点“最后”，出错了，应该是没有淡蓝色表示。 填色2.rar (10.08 KB, 下载次数: 1)

2014-1-26 16:38 上传

点击文件名下载附件

wszbd

大灰狼1976 发表于 2014-1-26 16:10
测试无问题，只根据你的需要改了range（“EU3：EW12")

你点“bbb”，出错了，应该是没有淡蓝色表示。 填色2.rar (9.75 KB, 下载次数: 2)

2014-1-26 16:42 上传

点击文件名下载附件

大灰狼1976

不对不对，我再看看

大灰狼1976

1. Sub bbb()
   
2. Dim arr, arr1, i&, j&, n&, s$
   
3. arr = Application.Transpose(Range("EU3:EW12"))
   
4. arr1 = [en1:ep1]
   
5. For j = 1 To 3
   
6.   s = Join(Application.Index(arr, j, 0), "")
   
7.   For i = 1 To 3
   
8.     If n < InStr(s, Mid(arr1(1, i), j, 1)) Then n = InStr(s, Mid(arr1(1, i), j, 1))
   
9.   Next i
   
10. Next j
    
11. If n = 10 Then Exit Sub
    
12. Range(Cells(n + 3, "eu"), Cells(UBound(arr, 2) + 2, "ew")).Interior.ColorIndex = 37
    
13. End Sub

复制代码

wszbd

大灰狼1976 发表于 2014-1-26 16:58

ok，谢谢老师！
能否再加一条语句：如果这个数在最后一行，没有淡蓝色显示，那么就把前三行显示为淡蓝色，像这样：

wszbd

大灰狼1976 发表于 2014-1-26 16:58

你点“bbb2”， 填色2.rar (11.37 KB, 下载次数: 2)

2014-1-26 17:48 上传

点击文件名下载附件 出错了，应该是这样：

选EN1：EP1没有出错。
选EO1：EP1没有出错。
选EP1出错。

谢谢！！！

大灰狼1976

15楼的条件也加进去了，代码请测试

1. Sub bbb2()
   
2. Dim arr, arr1, i&, j&, n&, s$, k&
   
3. arr = Application.Transpose(Range("EU3:EW12"))
   
4. arr1 = [ep1]
   
5. If Not IsArray(arr1) Then k = 1 Else k = UBound(arr1, 2)
   
6. For j = 1 To 3
   
7.   s = Join(Application.Index(arr, j, 0), "")
   
8.   For i = 1 To k
   
9.     If k = 1 Then
   
10.       If n < InStr(s, Mid(arr1, j, 1)) Then n = InStr(s, Mid(arr1, j, 1))
    
11.     Else
    
12.       If n < InStr(s, Mid(arr1(1, i), j, 1)) Then n = InStr(s, Mid(arr1(1, i), j, 1))
    
13.     End If
    
14.   Next i
    
15. Next j
    
16. If n = 10 Then [eu3:ew5].Interior.ColorIndex = 37: Exit Sub
    
17. Range(Cells(n + 3, "eu"), Cells(UBound(arr, 2) + 2, "ew")).Interior.ColorIndex = 37
    
18. End Sub

复制代码

wszbd

大灰狼1976 发表于 2014-1-26 18:10
15楼的条件也加进去了，代码请测试

非常完美，谢谢！！！