[已解决]A1:A10单元格设有公式，当A1抹掉公式输入数字时，A1单元格变红色。其他有公式的不变

qinhuan66

求助：A1:A10单元格内设有公式，当A1抹掉公式输入数字时，A1单元格变为红色。其他有公式的不变色。谢谢

最佳答案

月排行榜 / 总排行榜

xdragon

2014-1-19 11:46

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.    Set Rng = Intersect(Target, Range("A1:A10"))
   
3.    If Rng Is Nothing Then
   
4.       Exit Sub
   
5.    Else
   
6.       If CStr(Target.Value) = Target.Formula Then Target.Font.Color = vbRed
   
7.    End If
   
8. End Sub
   

复制代码

跳转到最佳答案楼层

xdragon

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.    Set Rng = Intersect(Target, Range("A1:A10"))
   
3.    If Rng Is Nothing Then
   
4.       Exit Sub
   
5.    Else
   
6.       If CStr(Target.Value) = Target.Formula Then Target.Font.Color = vbRed
   
7.    End If
   
8. End Sub
   

复制代码

qinhuan66

xdragon 发表于 2014-1-19 11:46

就是要这样的效果。谢谢。如果能加粗字体就更加OK。谢谢

qinhuan66

xdragon 发表于 2014-1-19 11:46

现当A1输入值时能变红色了，现没度出现两个小问题。1、如果想恢复公式把下面的公式向上拉，2、或者清2个以上单元格的公式（即A1、A2、A3一起清空）即出现下图所示的错误。


已生新发贴了
为什么会出现运行时错误类型不匹配。谢谢
http://www.excelpx.com/thread-317898-1-1.html

xdragon

qinhuan66 发表于 2014-1-19 12:27
现当A1输入值时能变红色了，现没度出现两个小问题。1、如果想恢复公式把下面的公式向上拉，2、或者清2个以 ...

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.    Dim rng
   
3.    For Each rng In Target
   
4.       If Intersect(rng, Range("A1:A10")) Is Nothing Then
   
5.         Exit Sub
   
6.       Else
   
7.          If CStr(rng.Value) = rng.Formula Then rng.Font.Color = vbRed: rng.Font.Bold = True
   
8.       End If
   
9.    Next
   
10. End Sub

复制代码

tgydslr

qinhuan66

xdragon 发表于 2014-1-19 12:35

老师又打扰你了，用了你的代码非常好用。但使用过程中发现了一个问题，就是当不在代码Range("c14:c25,g14:g25,k14:k25,o14:o25,s14:s25,c31:c42,g31:g42,k31:k42,o31:o42,s31:s42,c48:c59,g48:g59,k48:k59,o48:o59,s48:s59,c65:c76,g65:g76,k65:k76,o65:o76,s65:s76,c82:c93,g82:g93,k82:k93,o82:o93,s82:s93")) Is Nothing Then范围内输入即自动解除工作表保护（锁了保护的），不知道是什么原因。
王五.rar (57.83 KB, 下载次数: 5)

2014-1-20 09:48 上传

点击文件名下载附件

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2. With Sheets("个人缴费卡片")
   
3.     .Unprotect ("695360052")
   
4.    Dim rng
   
5.    For Each rng In Target
   
6.       If Intersect(rng, Range("c14:c25,g14:g25,k14:k25,o14:o25,s14:s25,c31:c42,g31:g42,k31:k42,o31:o42,s31:s42,c48:c59,g48:g59,k48:k59,o48:o59,s48:s59,c65:c76,g65:g76,k65:k76,o65:o76,s65:s76,c82:c93,g82:g93,k82:k93,o82:o93,s82:s93")) Is Nothing Then
   
7.         Exit Sub
   
8.       Else
   
9.          If CStr(rng.Value) = rng.Formula Then rng.Font.Color = vbRed: rng.Font.Bold = True
   
10.       End If
    
11.    Next
    
12.    .Protect ("695360052")
    
13.     End With
    
14. End Sub
    
15. 
    
16. <FONT color=red>已解决</FONT>

复制代码

xdragon

qinhuan66 发表于 2014-1-20 09:51
老师又打扰你了，用了你的代码非常好用。但使用过程中发现了一个问题，就是当不在代码Range("c14:c25,g14 ...

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2. With Sheets("个人缴费卡片")
   
3. Dim rng
   
4. For Each rng In Target
   
5. If Intersect(rng, Range("c14:c25,g14:g25,k14:k25,o14:o25,s14:s25,c31:c42,g31:g42,k31:k42,o31:o42,s31:s42,c48:c59,g48:g59,k48:k59,o48:o59,s48:s59,c65:c76,g65:g76,k65:k76,o65:o76,s65:s76,c82:c93,g82:g93,k82:k93,o82:o93,s82:s93")) Is Nothing Then
   
6. Exit Sub
   
7. Else
   
8. If CStr(rng.Value) = rng.Formula Then
   
9. .Unprotect ("695360052")
   
10. With rng.Font
    
11. .Color = vbRed
    
12. .Bold = True
    
13. End With
    
14. .Protect ("695360052")
    
15. End If
    
16. End If
    
17. Next
    
18. End With
    
19. End Sub

复制代码

不知道为啥，格式都没了。。你自己调整下吧。。。-。-