对象'Font'的方法'Color'失败

Question

我在Excel 2010 VBA代码中收到标题错误消息.我看过这个问题和这个看起来相似的问题,但是这个问题似乎解决了这个问题.

我的代码解析当前工作表上的所有条件格式并将其作为文本转储到另一个(新创建的)工作表 - 最终目标是将相同的条件加载到几乎相同的工作表(因此我不能只复制基础工作表).

代码是:

Public Sub DumpExistingRules()
'portions of the code from here: http://dailydoseofexcel.com/archives/2010/04/16/listing-format-conditions/

Const RuleSheetNameSuffix As String = "-Rules"

  Dim TheWB As Workbook
  Set TheWB = ActiveWorkbook

  Dim SourceSheet As Worksheet
  Set SourceSheet = TheWB.ActiveSheet

  Dim RuleSheetName As String
  RuleSheetName = SourceSheet.Name & RuleSheetNameSuffix
  On Error Resume Next                          'if the rule sheet doesn't exist it will error, we don't care, just move on
  Application.DisplayAlerts = False
  TheWB.Worksheets(RuleSheetName).Delete
  Application.DisplayAlerts = True
  On Error GoTo EH

  Dim RuleSheet As Worksheet
  Set RuleSheet = TheWB.Worksheets.Add
  SourceSheet.Activate
  RuleSheet.Name = RuleSheetName

  RuleSheet.Range(RuleSheet.Cells(1, CellAddrCol), RuleSheet.Cells(1, OperatorCodeCol)).Value = Array("Cell Address", "Rule Type", "Type Code", "Applies To", "Stop", "Font.ColorRGB", "Formula1", "Formula2", _
            "Interior.ColorIndexRGB", "Operator Type", "Operator Code")

  Dim RuleRow As Long
  RuleRow = 2
  Dim RuleCount As Long
  Dim RptCol As Long
  Dim SrcCol As Long
  Dim RetryCount As Long
  Dim FCCell As Range
  For SrcCol = 1 To 30
    Set FCCell = SourceSheet.Cells(4, SrcCol)
    For RuleCount = 1 To FCCell.FormatConditions.Count
      RptCol = 1
      Application.StatusBar = "Cell: " & FCCell.Address
      PrintValue RuleSheet, RuleRow, CellAddrCol, FCCell.Address
      PrintValue RuleSheet, RuleRow, RuleTypeCol, FCTypeFromIndex(FCCell.FormatConditions.Item(RuleCount).Type)
      PrintValue RuleSheet, RuleRow, RuleCodeCol, FCCell.FormatConditions.Item(RuleCount).Type
      PrintValue RuleSheet, RuleRow, AppliesToCol, FCCell.FormatConditions.Item(RuleCount).AppliesTo.Address
      PrintValue RuleSheet, RuleRow, StopCol, FCCell.FormatConditions.Item(RuleCount).StopIfTrue
      If FCCell.FormatConditions.Item(RuleCount).Type <> 8 Then
        PrintValue RuleSheet, RuleRow, Formula1Col, "'" & Right(FCCell.FormatConditions.Item(RuleCount).Formula1, Len(FCCell.FormatConditions.Item(RuleCount).Formula1) - 1)    'remove the leading "=" sign
        If FCCell.FormatConditions.Item(RuleCount).Type <> 2 And _
           FCCell.FormatConditions.Item(RuleCount).Type <> 1 Then
          PrintValue RuleSheet, RuleRow, Formula2Col, "'" & Right(FCCell.FormatConditions.Item(RuleCount).Formula2, Len(FCCell.FormatConditions.Item(RuleCount).Formula2) - 1)  'remove the leading "=" sign
        End If
      End If
      RetryCount = 0
RetryColor:
      PrintValue RuleSheet, RuleRow, FontColorCol, "'" & GetRGB(FCCell.FormatConditions(RuleCount).Font.Color)
      PrintValue RuleSheet, RuleRow, IntColorIdxCol, "'" & GetRGB(FCCell.FormatConditions.Item(RuleCount).Interior.Color)
      If FCCell.FormatConditions.Item(RuleCount).Type = 1 Then
        PrintValue RuleSheet, RuleRow, OperatorTypeCol, OperatorType(FCCell.FormatConditions.Item(RuleCount).Operator)
        PrintValue RuleSheet, RuleRow, OperatorCodeCol, FCCell.FormatConditions.Item(RuleCount).Operator
      End If
      RuleRow = RuleRow + 1
    Next
  Next

  RuleSheet.Rows(1).AutoFilter = True

CleanExit:
  If RuleRow = 2 Then
    PrintValue RuleSheet, RuleRow, RptCol, "No Conditional Formatted cells were found on " & SourceSheet.Name
  End If
  On Error Resume Next
  Set SourceSheet = Nothing
  Set TheWB = Nothing
  Application.StatusBar = ""
  On Error GoTo 0

  MsgBox "Done"

  Exit Sub

EH:
  If Err.Number = -2147417848 Then
    MsgBox "Font.Color = " & FCCell.FormatConditions(RuleCount).Font.Color
    If RetryCount < 5 Then
      RetryCount = RetryCount + 1
      Resume RetryColor
    Else
      MsgBox "RetryCount =  " & RetryCount
      Resume Next
    End If
  Else
    MsgBox "Error Number: " & Err.Number & vbCrLf & _
           " Description: " & Err.Description & vbCrLf & _
           "Cell Address: " & FCCell.Address & vbCrLf
    Resume Next
  End If

End Sub

有问题的行是紧跟在RetryColor:标签后面的行.当为Unique Values条件格式化规则执行该行代码时(即突出显示重复项),我得到err.number = -2147417848'和err.description = "Method 'Color' of object 'Font' failed".代码落入EH:,落入第一个IF语句,并显示MsgBox没有任何问题.

为什么语句FCCell.FormatConditions(RuleCount).Font.Color第一次失败,但在错误处理程序中第二次完美执行？一旦我点击了OK按钮MsgBox,就会在RetryColor:标签处继续执行,语句正确执行,一切都很好.

---

---

为了确保清楚,如果我注释掉了

MsgBox "Font.Color = " & FCCell.FormatConditions(RuleCount).Font.Color

行EH:,代码将错误5次而没有输出的RGB代码到我的工作输出,然后继续在它的途中.如果该行是在EH:(如上图所示),我得到了MsgBox和.Font.Color现在将在主代码读取和执行将继续按预期没有错误.

---

---

更新:看来,让这个代码后坐了一个星期,而我的工作是别的东西,它现在是稍微更坏了.在错误处理程序中,我现在得到一个标题错误消息,弹出.如果我点击F5,它将执行并显示MsgBox颜色代码.

所以现在,它将失败两次,然后在^第三次正确执行.

---

为了完整性,这里是代码GetRGB:

Private Function GetRGB(ByVal ColorCode As Variant) As String

  Dim R As Long
  Dim G As Long
  Dim B As Long

  If IsNull(ColorCode) Then
    GetRGB = "0,0,0"
  Else
    R = ColorCode Mod 256
    G = ColorCode \ 256 Mod 256
    B = ColorCode \ 65536 Mod 256

    GetRGB = R & "," & G & "," & B
  End If

End Function

我必须将参数作为一个传递,Variant因为当在颜色选择器中.Font.Color设置Automatic为时,我得到一个NULL返回,因此If声明中GetRGB.

另一个更新:让这段代码再过几个星期(这是为了让我的生活变得更轻松,而不是一个官方项目,因此它位于优先级列表的底部),它似乎会在每次调用时产生错误,而不仅仅是有时候.但是,代码将在即时窗口中正确执行!

黄色突出显示的行是生成错误的行,但您可以在即时窗口中看到结果.

---

另外(我意识到这应该是另一个问题),如果有人碰巧看到任何原因SourceSheet.Activate,请告诉我 - 没有它我会得到随机错误,所以我把它放进去.通常这些错误是因为不合格工作在当前活动工作表上的引用(RuleSheet创建它的时间尽快),但我认为我的所有引用都是合格的.如果你看到我错过的东西,请管好!否则,我可能会转到CodeReview让他们看看我错过了什么,一旦我正常工作.

Answer 1

关于你的第二个问题：
我一直在设置不在活动工作表中的单元格时遇到问题，最可能的问题原因SourceSheet.Activate取决于稍后设置范围的事实：

Set FCCell = SourceSheet.Cells(4, SrcCol)

我发现，如果工作表未处于活动状态，它会在 cells() 参数中失败，我认为最好的方法是在单元格之前使用范围。
情况可能是这样。所以对于这个例子我会做类似的事情：

With SourceSheet:Set FCCell = .Range(.Cells(4,SrcCol):End With