可删除所有单元格的条件格式并保留结果格式的宏

single_star

附档宏可将Excel具条件格式单元格的条件格式删除,结果格式(底色及字型,外框)依然保留

[ 本帖最后由 single_star 于 2009-7-22 10:36 编辑 ]

single_star

'***楼上附档代码公布如下(所有条件格式单元格的结果格式皆可保留)
Sub Translate_Formatconditions_Celltype()
Set range0 = Application.Intersect(Selection, ActiveCell.SpecialCells(xlCellTypeAllFormatConditions))
If range0 Is Nothing Then Exit Sub
'*************************************************
Application.ScreenUpdating = False
Dim jd(8)      'set this for 8 FormatConditionOperator
jd(1) = "=And(cell0>=for1,cell0<=for2)"    'Between
jd(2) = "=Not(And(cell0>=for1,cell0<=for2))"       'notBetween
jd(3) = "=cell0=for1"               '=
jd(4) = "=cell0<>for1"              '<>
jd(5) = "=cell0>for1"               '>
jd(6) = "=cell0<for1"               '<
jd(7) = "=cell0>=for1"              '>=
jd(8) = "=cell0<=for1"              '<=

For Each sel0 In range0
n = sel0.FormatConditions.Count
  con = 0
  For i = n To 1 Step -1
  With sel0
  sel0.Select 'use this to avoid formula wrong answer with row() or column()
'****.FormatConditions(i).Type: xlCellValue
  If .FormatConditions(i).Type = 1 Then
    s0 = sel0.Value2
    operator0 = .FormatConditions(i).Operator
    a0 = Application.Evaluate(.FormatConditions(i).Formula1)
    If operator0 = 1 Or operator0 = 2 Then
    b0 = Application.Evaluate(.FormatConditions(i).Formula2)
    If Not (IsNumeric(s0)) Or Not (IsNumeric(a0)) Or Not (IsNumeric(b0)) Then
      If IsEmpty(s0) Then s0 = ""
      If IsNumeric(s0) Then s0 = CStr(s0)
      If IsEmpty(a0) Then a0 = ""
      If IsNumeric(a0) Then a0 = CStr(a0)
      If IsEmpty(b0) Then b0 = ""
      If IsNumeric(b0) Then b0 = CStr(b0)
      Else
      If IsEmpty(s0) Then s0 = 0
      If IsEmpty(a0) Then a0 = 0
      If IsEmpty(b0) Then b0 = 0
    End If

      If a0 > b0 Then
       a1 = b0
       b1 = a0
      Else
       a1 = a0
       b1 = b0
      End If
    Else
      a1 = a0
    End If
       If Application.WorksheetFunction.IsText(s0) Then s0 = """" & UCase(s0) & """"
      If Application.WorksheetFunction.IsText(a1) Then a1 = """" & UCase(a1) & """"
      If Application.WorksheetFunction.IsText(b1) Then b1 = """" & UCase(b1) & """"
      st0 = jd(operator0)
      st = Replace(st0, "for1", a1)
      st = Replace(st, "for2", b1)
      st = Replace(st, "cell0", s0)
      If Application.WorksheetFunction.IsError(Application.Evaluate(st)) Then
        ans = False
      Else
       ans = Application.Evaluate(st)
      End If
'****.FormatConditions(i).Type:xlExpression
    Else
      If Application.WorksheetFunction.IsError(Application.Evaluate(.FormatConditions(i).Formula1)) Then
        ans = False
      Else
       ans = Application.Evaluate(.FormatConditions(i).Formula1)
      End If
    End If
  End With
  If ans = True Then con = i
  Next
'***translate celltype(Font&Interior&Borders)
If con > 0 Then
  Set s1 = sel0.FormatConditions(con).Font
  Set s2 = sel0.FormatConditions(con).Interior
  With sel0.Font
    .Bold = s1.Bold
    .Italic = s1.Italic
    .Underline = s1.Underline
    .Strikethrough = s1.Strikethrough
    .ColorIndex = s1.ColorIndex
  End With
  sel0.Interior.Pattern = s2.Pattern
  sel0.Interior.ColorIndex = s2.ColorIndex
   
  For b0 = 1 To 4
   If sel0.FormatConditions(con).Borders(b0).LineStyle <> xlNone Then
      sel0.Borders(b0).LineStyle = sel0.FormatConditions(con).Borders(b0).LineStyle
      sel0.Borders(b0).Weight = sel0.FormatConditions(con).Borders(b0).Weight
      sel0.Borders(b0).ColorIndex = sel0.FormatConditions(con).Borders(b0).ColorIndex
   End If
  Next
End If

sel0.FormatConditions.Delete
Next
Application.ScreenUpdating = True
End Sub

[ 本帖最后由 single_star 于 2009-8-3 17:31 编辑 ]

joyark

做得不错！鼓励一下。

single_star

zdqwy19 发表于 2012-9-9 07:58
我把你的代码修改成提取单元格背景色的function进程，在excel2007中，当条件格式多于2个事，返回#value，当 ...

我写的function参考帖。。。
http://club.excelhome.net/thread-477227-1-1.html


如还有问题的话，请把修改代码后的附件上传一下。。。

zdqwy19

我把你的代码修改成提取单元格背景色的function进程，在excel2007中，当条件格式多于2个事，返回#value，当条件格式不多于2个时返回正常值。

zdqwy19

single_star 发表于 2012-9-10 10:34
我写的function参考帖。。。
http://club.excelhome.net/thread-477227-1-1.html

谢谢了！你的那个贴已经解决了我的问题。

lj1226189

附件文件打不开怎么回事！！！