单元格条件格式-VBA实现单元格条件格式的属性、方法（2）

接上帖：http://www.excel-cn.com/tip/325-cn.html

8、用VBA代码转化条件格式为真的属性值为单元格的属性值
Sub Hold_FormatConditions_Result()
'转化条件格式成立，保留单元格条件格式属性的结果
'1、单元格内部颜色属性
'2、单元格字体属性
'3、单元格边框样式属性
'4、单元格底纹样式属性
On Error Resume Next '避免没有条件格式的单元格
 Application.ScreenUpdating = False
    Dim s_Operator(8) '存放操作符的数组
    Dim Rng As Range, t_Rng As Range
    Dim t_Rng_Val '含条件格式单元格的值
    Dim Operator_sTr% '操作符类型对应的序号
    Dim V_Fc_1, V_Fc_2 '表达式1、2中的结果
    Dim t_V_Fc_a, t_V_Fc_b '临时变量
    Dim s_Strs, s_Str '操作符
    Dim ans As Boolean '判断条件成立与否的变量
    Dim Con%, n%, i%
    Dim s1 As Object '条件格式中的单元格字体
    Dim s2 As Object '条件格式中的单元格内部
    Dim s3 As Object '条件格式中的单元格边框
    s_Operator(1) = "=And(vCell>=For1,vCell<=For2)"    'Between
    s_Operator(2) = "=Not(And(vCell>=For1,vCell<=For2))"       'NotBetween
    s_Operator(3) = "=vCell=For1"               '=
    s_Operator(4) = "=vCell<>For1"              '<>
    s_Operator(5) = "=vCell>For1"               '>
    s_Operator(6) = "=vCell
    s_Operator(7) = "=vCell>=For1"              '>=
    s_Operator(8) = "=vCell<=For1"              '<=
    Set Rng = Cells.SpecialCells(xlCellTypeAllFormatConditions)
    For Each t_Rng In Rng
        n = t_Rng.FormatConditions.Count '获取含单元格的条件格式总数
        If n > 0 Then
            Con = 0
            For i = n To 1 Step -1
                With t_Rng
                    t_Rng.Select '此语句是为了调试方便留下的，可以根据情况删除
                    If .FormatConditions(i).Type = 1 Then '条件单元格为值类型
                        t_Rng_Val = t_Rng.Value '取得含条件格式单元格的值
                        Operator_sTr = .FormatConditions(i).Operator '返回该条件格式的操作符
                        '返回该条件格式中的条件表达式1
                        V_Fc_1 = Application.Evaluate(.FormatConditions(i).Formula1)
                        '操作符为介于或者不介于
                        If Operator_sTr = 1 Or Operator_sTr = 2 Then
                         '返回该条件格式中的条件表达式2
                            V_Fc_2 = Application.Evaluate(.FormatConditions(i).Formula2)
                            '单元格值、条件格式表达1的值、条件格式表达2的值是不为数值类型
                            If Not (IsNumeric(t_Rng_Val)) Or Not (IsNumeric(V_Fc_1)) Or Not (IsNumeric(V_Fc_2)) Then
                                '为空值，则转换为 "" 类型
                                If IsEmpty(t_Rng_Val) Then t_Rng_Val = ""
                                '为数值，则转换为字符类型
                                If IsNumeric(t_Rng_Val) Then t_Rng_Val = CStr(t_Rng_Val)
                                '表达式1为空值，则转换为 "" 类型
                                If IsEmpty(V_Fc_1) Then V_Fc_1 = ""
                                '表达式1为数值，则转换为字符类型
                                If IsNumeric(V_Fc_1) Then V_Fc_1 = CStr(V_Fc_1)
                                '表达式2为空值，则转换为 "" 类型
                                If IsEmpty(V_Fc_2) Then V_Fc_2 = ""
                                '表达式2为空值，则转换为字符类型
                                If IsNumeric(V_Fc_2) Then V_Fc_2 = CStr(V_Fc_2)
                            Else
                                If IsEmpty(t_Rng_Val) Then t_Rng_Val = 0
                                If IsEmpty(V_Fc_1) Then V_Fc_1 = 0
                                If IsEmpty(V_Fc_2) Then V_Fc_2 = 0
                            End If

  '表达式1、表达式2的比较
                            If V_Fc_1 > V_Fc_2 Then
                                t_V_Fc_a = V_Fc_2
                                t_V_Fc_b = V_Fc_1
                            Else
                                t_V_Fc_a = V_Fc_1
                                t_V_Fc_b = V_Fc_2
                            End If
                        Else '操作符序号大于2的情况
                            t_V_Fc_a = V_Fc_1
                            If t_Rng_Val < V_Fc_1 Then
                            '单元格值小于条件格式的设置的值，即条件成立的情况
                                ans = True
                                Con = i
                                Exit For
                            End If
                        End If
                        '单元格值、条件格式表达式1、条件格式表达式2的返回值：为文本时，将小写英文字符转换为大写英文字符
                        If Application.WorksheetFunction.IsText(t_Rng_Val) Then t_Rng_Val = """" & UCase(t_Rng_Val) & """"
                        If Application.WorksheetFunction.IsText(t_V_Fc_a) Then t_V_Fc_a = """" & UCase(t_V_Fc_a) & """"
                        If Application.WorksheetFunction.IsText(t_V_Fc_b) Then t_V_Fc_b = """" & UCase(t_V_Fc_b) & """"
                        '返回s_Str字符串中的操作符为:可转换一个对象或者一个值做替换操作
                        s_Strs = s_Operator(Operator_sTr)
                        s_Str = Replace(s_Strs, "For1", t_V_Fc_a)
                        s_Str = Replace(s_Str, "For2", t_V_Fc_b)
                        s_Str = Replace(s_Str, "vCell", t_Rng_Val)
                        '将s_Str 转换为值出现错误时
                        If Application.WorksheetFunction.IsError(Application.Evaluate(s_Str)) Then
                        Else '转换成功。则条件格式成立
                            ans = Application.Evaluate(s_Str)
                        End If

                    Else '条件格式为公式
                        If Application.WorksheetFunction.IsError(Application.Evaluate(.FormatConditions(i).Formula1)) Then
                        Else
                            ans = Application.Evaluate(.FormatConditions(i).Formula1)
                            Con = i
                        End If
                    End If
                End With
            Next
            If Con > 0 Then
                Set s1 = t_Rng.FormatConditions(Con).Font '条件格式中设置的字体
                Set s2 = t_Rng.FormatConditions(Con).Interior '条件格式中设置的单元格内部
                Set s3 = t_Rng.FormatConditions(Con).Borders '条件格式中设置的单元格边框
                With t_Rng.Font '条件格式成立的单元格字体
                    .Bold = s1.Bold '加粗
                    .Italic = s1.Italic '斜体
                    .Underline = s1.Underline '下划线
                    .Strikethrough = s1.Strikethrough '删除线
                    .ColorIndex = s1.ColorIndex '字体颜色索引号
                End With
                With t_Rng
                    .Interior.ColorIndex = s2.ColorIndex  '单元格内部颜色索引号
                    .Interior.Pattern = s2.Pattern '单元格内部图案
                    .Interior.PatternColorIndex = s2.PatternColorIndex '单元格内部图案颜色索引号
                    .Borders.LineStyle = s3.LineStyle '单元格边框线类型
                    .Borders.ColorIndex = s3.ColorIndex '单元格边框线颜色索引号
                    .Borders.Weight = s3.Weight '边框线宽度（粗细）
                    .FormatConditions.Delete '删除条件格式
                End With
            End If
        End If
    Next
    Application.ScreenUpdating = False
End Sub    


     本帖的程序测试在Excel2003下通过。引用的帮助内容出自Excel2003VBA中。希望本帖起到资料或者工具的作用，既方便自己的快速查阅，也方便了有此需求的朋友。

转载自：Aeolian-Vox(ExcelHome )