[已解决]按条件填充颜色

left369

按条件填充颜色

最佳答案

月排行榜 / 总排行榜

dsmch

2015-1-3 15:24

1. Sub Macro1()
   
2. Dim arr, rng As Range, j%
   
3. arr = Range("a16").CurrentRegion
   
4. ActiveSheet.UsedRange.Interior.ColorIndex = xlNone
   
5. For j = 1 To UBound(arr, 2)
   
6.     s = Application.CountIf(Cells(16, j).Resize(4), arr(2, j))
   
7.     If arr(2, j) = arr(3, j) And s = 2 Then
   
8.         If rng Is Nothing Then
   
9.             Set rng = Cells(17, j).Resize(2)
   
10.         Else
    
11.             Set rng = Union(rng, Cells(17, j).Resize(2))
    
12.         End If
    
13.     End If
    
14. Next
    
15. If Not rng Is Nothing Then rng.Interior.ColorIndex = 7
    
16. End Sub

复制代码

跳转到最佳答案楼层

qh8600

笔.rar (8.8 KB, 下载次数: 9)

2015-1-3 12:04 上传

点击文件名下载附件

left369

qh8600 发表于 2015-1-3 12:04

不用格式，可以用代码么

baksy

选定16:19行，设置格式
=OR(AND(A$17=A$18,A$17=A$16),AND(A$17=A$18,A$17=A$19))
选定17:18行，设置格式
=(A$17=A$18)

left369

有VBA的吗

dsmch

1. Sub Macro1()
   
2. Dim arr, rng As Range, j%
   
3. arr = Range("a16").CurrentRegion
   
4. ActiveSheet.UsedRange.Interior.ColorIndex = xlNone
   
5. For j = 1 To UBound(arr, 2)
   
6.     s = Application.CountIf(Cells(16, j).Resize(4), arr(2, j))
   
7.     If arr(2, j) = arr(3, j) And s = 2 Then
   
8.         If rng Is Nothing Then
   
9.             Set rng = Cells(17, j).Resize(2)
   
10.         Else
    
11.             Set rng = Union(rng, Cells(17, j).Resize(2))
    
12.         End If
    
13.     End If
    
14. Next
    
15. If Not rng Is Nothing Then rng.Interior.ColorIndex = 7
    
16. End Sub

复制代码