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

wszbd

填色2.rar (2.99 KB, 下载次数: 26)

2014-1-26 02:45 上传

点击文件名下载附件


解释：
1）在EU3：EU12中分别找到EN,EO,EP三个单元格的第一个数。
2）在EV3：EV12中分别找到EN,EO,EP三个单元格的第二个数。
3）在EW3：EW12中分别找到EN,EO,EP三个单元格的第三个数。
4）比较找到的所有数（大约9个），看哪个数在最下面（本例为EV9的单元格1），
     就把这个数的下面翻为淡蓝色（EU,EV,EW这三列）。


注，写VBA时，最好一步一步来，我好修改。比如 三个单元格（EN,EO,EP）可改为两个（EO,EP）或一个（EP）。
sheet2为例(效果），数字加颜色是为了好区分，没有别的意思。


谢谢！！！

最佳答案

月排行榜 / 总排行榜

大灰狼1976

2014-1-26 18:10

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

复制代码

跳转到最佳答案楼层

爱疯

可能50%的朋友进来立刻走了，因为无法直接看到问题的说明和截图（已给你改了）。
虽然麻烦些了，但比起能够解决问题，还是值得的。


题意懂了
1）不处理ET列？！
2）数据源再多点是怎样子的？

eaglexs

请测试：

1. Sub 填色()
   
2.     Dim arr, brr, iRow%, i%, j%, k%, Num%
   
3.     With Sheets(1)
   
4.         arr = .Range("en1:ep1")
   
5.         brr = .Range("et3").CurrentRegion
   
6.         For i = 2 To UBound(brr, 2)
   
7.             For k = 1 To UBound(arr, 2)
   
8.                 Num = Mid(arr(1, k), i - 1, 1)
   
9.                 For j = 1 To UBound(brr)
   
10.                     If brr(j, i) = Num Then
    
11.                         If iRow < j Then iRow = j
    
12.                         Exit For
    
13.                     End If
    
14.                 Next
    
15.             Next
    
16.         Next
    
17.         .Range(.Cells(iRow + 3, "eu"), .Cells(UBound(brr) + 2, "ew")).Interior.Color = RGB(153, 204, 255)
    
18.     End With
    
19. End Sub
    

复制代码

大灰狼1976

附件请测试

1. Sub aaa()
   
2. Dim arr, arr1, i&, j&, n&, s$
   
3. arr = Application.Transpose([et3].CurrentRegion)
   
4. arr1 = [en1:ep1]
   
5. For j = 1 To 3
   
6.   s = Join(Application.Index(arr, j + 1, 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. Range(Cells(n + 3, "eu"), Cells(UBound(arr, 2) + 2, "ew")).Interior.ColorIndex = 37
    
12. End Sub

复制代码

wszbd

eaglexs 发表于 2014-1-26 10:11
请测试：

有点问题，老师看看： 填色2.rar (9.02 KB, 下载次数: 4)

2014-1-26 12:05 上传

点击文件名下载附件

能否加上这样的语句：range（“EU3：EW12")

谢谢！！！

wszbd

大灰狼1976 发表于 2014-1-26 12:00
附件请测试

有点问题，老师看看： 填色2.rar (9.09 KB, 下载次数: 2)

2014-1-26 12:11 上传

点击文件名下载附件

能否加上这样的语句：range（“EU3：EW12")

谢谢！！！

wszbd

爱疯 发表于 2014-1-26 09:10
可能50%的朋友进来立刻走了，因为无法直接看到问题的说明和截图（已给你改了）。
虽然麻烦些了，但比起能够 ...

1）不处理ET列？！
答：是的，不处理ET列。


2）数据源再多点是怎样子的？
答：因为EN1：EP1是三位数，所以先就这么多数据。


谢谢！！！

eaglexs

wszbd 发表于 2014-1-26 12:07
有点问题，老师看看：

能否加上这样的语句：range（“EU3：EW12")

原始的数据在EU1:EW2间没有文字数据，我用range("eu3").currentregion就能把ET3:EW12之间的数据包括起来。
现在的数据，你在EU1:EW2之间加了文字，再用currentregion就不太合适了。
改一下brr引用数据源的方法，就没有问题了

1. Sub 填色2()
   
2.     Dim arr, brr, iRow%, i%, j%, k%, Num%
   
3.     With Sheets(1)
   
4.         arr = .Range("en1:ep1")
   
5.         brr = .Range("et3", .Cells(Rows.Count, "ew").End(xlUp)).Value
   
6.         For i = 2 To UBound(brr, 2)
   
7.             For k = 1 To UBound(arr, 2)
   
8.                 Num = Mid(arr(1, k), i - 1, 1)
   
9.                 For j = 1 To UBound(brr)
   
10.                     If brr(j, i) = Num Then
    
11.                         If iRow < j Then iRow = j
    
12.                         Exit For
    
13.                     End If
    
14.                 Next
    
15.             Next
    
16.         Next
    
17.         .Range(.Cells(iRow + 3, "eu"), .Cells(UBound(brr) + 2, "ew")).Interior.Color = RGB(153, 204, 255)
    
18.     End With
    
19. End Sub

复制代码

eaglexs

wszbd 发表于 2014-1-26 12:07
有点问题，老师看看：

能否加上这样的语句：range（“EU3：EW12")

你要这样也可以。
把代码第5-6行改成

1.         brr = .Range("eu3:ew12")
   
2.         For i = 1 To 3

复制代码

只是这样看起来少了一点灵活性

大灰狼1976

1. Sub aaa()
   
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. Range(Cells(n + 3, "eu"), Cells(UBound(arr, 2) + 2, "ew")).Interior.ColorIndex = 37
    
12. End Sub

复制代码

测试无问题，只根据你的需要改了range（“EU3：EW12")