VBA 动态条件格式

雄鹰

在工作表中，每当单元格内输入一个值，当超过达到或超过5个时，工作表中所有与本单元格（刚输入的）相同的单元格全部充填黄色。
用VBA代码如何编写？
我的代码总是不能运行，错误就在这里：
   Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
        Formula1:="=" & Target.Value & ""


下面是我的代码：
Private Sub Worksheet_Change(ByVal Target As Range)
   Application.ScreenUpdating = False
   Cells.Select  '去掉充填色
    With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Cells.Select    '清除条件格式
    Cells.FormatConditions.Delete

   warng = 5
   Set qy = Worksheets("Sheet1").Cells  '设置区域
    If Target.Value = "" Then GoTo 100   '空值略过
    mon = WorksheetFunction.CountIf(qy, Target)   '非空计数
    If mon >= warng Then    '与标准值对照，超过进行处理：
       Target.ClearComments   '清除原有标注

       '设置标注内容
       Text = "注意：" & Chr(10) & _
                Target.Address(0, 0) & "=" & Target.Value & "  出现  " & mon & "  次!"
       Target.AddComment   '添加标注
       Target.Comment.Text Text:=Text   '写入内容
       '对重复值区域进行充填底色，方便查找：

    Cells.Select
    Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
        Formula1:="=" & Target.Value & ""
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 65535
        .TintAndShade = 0
    End With

    End If
100:
    Cells(Target.Row + 1, Target.Column).Select
    Application.ScreenUpdating = True
End Sub

雄鹰

我自己解决了：
Private Sub Worksheet_Change(ByVal Target As Range)
   Application.ScreenUpdating = False
   Cells.Select  '去掉充填色
    With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Cells.Select    '清除条件格式
    Cells.FormatConditions.Delete

   warng = 5
   Set qy = Worksheets("Sheet1").Cells  '设置区域
    If Target.Value = "" Then GoTo 100   '空值略过
    a = Target.Value
    mon = WorksheetFunction.CountIf(qy, Target)   '非空计数
    If mon >= warng Then    '与标准值对照，超过进行处理：
    Cells.Select
    Cells.ClearComments    '清除原有标注
      
       '设置标注内容
       Text = "注意：" & Chr(10) & _
                Target.Address(0, 0) & "=" & Target.Value & "  出现  " & mon & "  次!"
       Target.AddComment   '添加标注
       Target.Comment.Text Text:=Text   '写入内容
      
       '对重复值区域进行充填底色，方便查找：
        Cells.Select
        Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
            Formula1:="=" & """" & a & """"
        Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
        With Selection.FormatConditions(1).Interior
            .PatternColorIndex = xlAutomatic
            .Color = 65535
            .TintAndShade = 0
        End With
End If
100:
    Cells(Target.Row + 1, Target.Column).Select
    Application.ScreenUpdating = True
End Sub

雄鹰

另一个问题：
字符可以正常工作，数值不行，大神们，怎么处理？

france723

雄鹰 发表于 2017-5-28 10:05
另一个问题：
字符可以正常工作，数值不行，大神们，怎么处理？

可以投机使用Mid函数。比如b是数值，c就把它转化成了字符。

1. Dim b, c As String
   
2. b = 3
   
3. c = Mid(b, 1)

复制代码

雄鹰

france723 发表于 2017-5-28 17:29
可以投机使用Mid函数。比如b是数值，c就把它转化成了字符。

谢谢，但是这不是解决问题的好办法，如何用VBA解决数字条件格式？

france723

雄鹰 发表于 2017-5-30 20:04
谢谢，但是这不是解决问题的好办法，如何用VBA解决数字条件格式？

CStr函数进行转换

雄鹰

数值、字符串的可以了，但是日期型的还是不能充填颜色：
Private Sub Worksheet_Change(ByVal Target As Range)
   On Error GoTo 100  '遇错略过
   Application.ScreenUpdating = False   '关闭屏幕更新，加快响应
   warng = 5   '设置警报线
   Set qy = Worksheets("Sheet1").Cells  '设置区域
   If Target.Value = "" Then GoTo 100   '空值略过
   
   a = Target.Value + 0  '对输入参数进行类型判断区分
   If WorksheetFunction.IsNumber(a) Then
        mon = WorksheetFunction.CountIf(qy, Target.Value)    '数值型计数
   Else
        mon = WorksheetFunction.CountIf(qy, a)    '字符型计数
   End If
   
   If mon >= warng Then    '与警报线标准值对照，超过进行处理：
       Cells.Select  '去掉充填色
       With Selection.Interior
            .Pattern = xlNone
            .TintAndShade = 0
            .PatternTintAndShade = 0
       End With
       Cells.FormatConditions.Delete    '清除条件格式
       Cells.ClearComments    '清除原有标注
            
      '设置标注内容
       Text = "注意：" & Chr(10) & _
                     Target.Address(0, 0) & "=" & Target.Value & "  出现  " & mon & "  次!"
       Target.AddComment   '添加标注
       Target.Comment.Text Text:=Text   '写入内容
            
      '对重复值区域进行充填底色，方便查找：
       If WorksheetFunction.IsNumber(a) Then
             Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
                 Formula1:="=" & a
             Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
             With Selection.FormatConditions(1).Interior
                 .Color = 65535
             End With
        Else
             Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
                 Formula1:="=" & """" & a & """"
             Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
             With Selection.FormatConditions(1).Interior
                 .Color = 65535
             End With
        End If
         
   End If
100:
    Cells(Target.Row + 1, Target.Column).Select
    Application.ScreenUpdating = True
End Sub