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

excelpxfans001 · 发表于 2016-6-9 10:48

按要求填充颜色

最佳答案

老司机带带我

2016-6-9 13:35

代码如下：

Sub xx()
Dim arr(), brr(), r&, c&, j&, i&, rng As Range, d1 As Object, d2 As Object
Set rng = Sheet1.Range("B8:T12") '自己设定范围
arr = Array(0, 1, 4, 5, 8)
brr = Array(2, 3, 6, 7, 9)
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
For i = 0 To UBound(arr)
d1.Add arr(i), ""
d2.Add brr(i), ""
Next
With rng
r = rng.Rows.Count
c = rng.Columns.Count
For i = 1 To c
For j = 2 To r
If d1.Exists(rng(j - 1, i).Value) And d2.Exists(rng(j, i).Value) Then rng(j, i).Interior.Color = 192
If d2.Exists(rng(j - 1, i).Value) And d1.Exists(rng(j, i).Value) Then rng(j, i).Interior.Color = 192
Next
Next
End With
End Sub

复制代码

老司机带带我 · 发表于 2016-6-9 13:35

代码如下：

Sub xx()
Dim arr(), brr(), r&, c&, j&, i&, rng As Range, d1 As Object, d2 As Object
Set rng = Sheet1.Range("B8:T12") '自己设定范围
arr = Array(0, 1, 4, 5, 8)
brr = Array(2, 3, 6, 7, 9)
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
For i = 0 To UBound(arr)
d1.Add arr(i), ""
d2.Add brr(i), ""
Next
With rng
r = rng.Rows.Count
c = rng.Columns.Count
For i = 1 To c
For j = 2 To r
If d1.Exists(rng(j - 1, i).Value) And d2.Exists(rng(j, i).Value) Then rng(j, i).Interior.Color = 192
If d2.Exists(rng(j - 1, i).Value) And d1.Exists(rng(j, i).Value) Then rng(j, i).Interior.Color = 192
Next
Next
End With
End Sub

复制代码

		自动登录	找回密码
密码			注册