[已解决]请教颜色代码如何实现

qh8600

颜色.rar (7.47 KB, 下载次数: 5)

2014-3-24 13:31 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2014-3-24 14:00

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.     With Target
   
3.         If .CountLarge > 1 Then Exit Sub
   
4.         If .Column <> 6 Then Exit Sub
   
5.         If Len(.Value) = 0 Then
   
6.             .Interior.ColorIndex = 0
   
7.             Exit Sub
   
8.         End If
   
9. 
   
10.         Dim rg As Range
    
11.         Set rg = Columns(1).Find(what:=.Value, lookat:=xlWhole)
    
12.         If rg Is Nothing Then
    
13.             .Interior.ColorIndex = 0
    
14.         Else
    
15.             .Interior.ColorIndex = rg.Offset(, 1).Value
    
16.         End If
    
17.     End With
    
18. End Sub

复制代码

上面有点小BUG，忘了加EXIT SUB了。

跳转到最佳答案楼层

hwc2ycy

底纹色是修改range对象的interior来实现。

hwc2ycy

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.     If Target.CountLarge > 1 Then Exit Sub
   
3.     If Target.Column <> 6 Then Exit Sub
   
4.     If Len(Target.Value) = 0 Then
   
5.         Target.Interior.ColorIndex = 0
   
6.     End If
   
7.     Dim rg As Range
   
8.     Set rg = Columns(1).Find(what:=Target.Value, lookat:=xlWhole)
   
9.     If rg Is Nothing Then
   
10.         Target.Interior.ColorIndex = 0
    
11.     Else
    
12.         Target.Interior.ColorIndex = rg.Offset(, 1).Value
    
13.     End If
    
14. End Sub

复制代码

hwc2ycy

颜色.rar (10.05 KB, 下载次数: 4)

2014-3-24 13:59 上传

点击文件名下载附件

hwc2ycy

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.     With Target
   
3.         If .CountLarge > 1 Then Exit Sub
   
4.         If .Column <> 6 Then Exit Sub
   
5.         If Len(.Value) = 0 Then
   
6.             .Interior.ColorIndex = 0
   
7.             Exit Sub
   
8.         End If
   
9. 
   
10.         Dim rg As Range
    
11.         Set rg = Columns(1).Find(what:=.Value, lookat:=xlWhole)
    
12.         If rg Is Nothing Then
    
13.             .Interior.ColorIndex = 0
    
14.         Else
    
15.             .Interior.ColorIndex = rg.Offset(, 1).Value
    
16.         End If
    
17.     End With
    
18. End Sub

复制代码

上面有点小BUG，忘了加EXIT SUB了。

hwc2ycy

另外，B列颜色码没有做校验，假设你输入的颜色码都是合法的，否则会要报错。
当B列颜色列为无效颜色值，则背景填充色直接改为无色

1.     On Error Resume Next
   
2.     With Target
   
3.         If .CountLarge > 1 Then Exit Sub
   
4.         If .Column <> 6 Then Exit Sub
   
5.         If Len(.Value) = 0 Then
   
6.             .Interior.ColorIndex = xlColorIndexNone
   
7.             Exit Sub
   
8.         End If
   
9. 
   
10.         Dim rg As Range
    
11.         Set rg = Columns(1).Find(what:=.Value, lookat:=xlWhole)
    
12.         If rg Is Nothing Then
    
13.             .Interior.ColorIndex = xlColorIndexNone
    
14.         Else
    
15.             .Interior.ColorIndex = rg.Offset(, 1).Value
    
16.             If Err.Number <> 0 Then
    
17.                 .Interior.ColorIndex = xlColorIndexNone
    
18.             End If
    
19.         End If
    
20.     End With
    
21. End Sub
    

复制代码

风林火山

1. Sub Macro1()
   
2.     Dim arr, k%, i%
   
3.     arr = Range("a1").CurrentRegion
   
4.     For k = 2 To Cells(Rows.Count, 6).End(3).Row
   
5.         For i = 2 To UBound(arr)
   
6.             If Cells(k, 6) = arr(i, 1) Then
   
7.                 Cells(k, 6).Interior.ColorIndex = Cells(i, 3).Interior.ColorIndex
   
8.             End If
   
9.         Next i
   
10.     Next k
    
11. End Sub
    

复制代码

qh8600

风林火山 发表于 2014-3-24 14:07

谢谢老师，你写的同样可以实现。