0

我正在为工作簿中的各种工作表开发导出宏。话虽如此，我需要使用带有导出宏的工作表来导出指定范围（命名范围）的值以及它们从条件格式中保存的颜色格式。

我不需要的一件事是复制创建着色的条件格式。我只想要范围内各个单元格的结果颜色。

我已经这样做了，代码如下，但是当我打开汇总文件时，所有有问题的单元格都有与之关联的条件格式模式，这会导致着色问题。

ws.range("rngAreaMetricDetail").Copy   'Area Mgr Store Metrics
newws.range("V3").PasteSpecial xlPasteValues    'Paste Values
newws.range("V3").PasteSpecial xlPasteFormats  'Paste Coloring
newws.Names.Add "rngAreaMetricDetail", Selection   'Create Named-Range from Selection

提前谢谢。

4

3 回答 3

2

Excel 没有简单的方法将条件格式转换为条件格式的结果。您必须手动完成所有操作：

  • 检查是否在每个单元格上使用了 FormatCondition。
  • 从 FormatCondition 手动分配格式。( Borders, Font, Interior, & NumberFormat)
  • 如果您有多个 FormatCondition，则后面的格式会覆盖前面的格式，除非StopIfTrue已设置。

如果您安装了 Microsoft Word，您可以将您的范围复制到 Word，然后再复制回 Excel，让 Word 负责转换格式。

Sub CopyConditionalFormattingThruWord(sAddress As String)
   Dim appWord As Word.Application, doc As Word.Document
   Dim wbkTo As Workbook

   ' copy from original table
   ThisWorkbook.Activate
   ThisWorkbook.Names!rngAreaMetricDetail.RefersToRange.Copy

   ' paste into word application and recopy
   Set appWord = New Word.Application
   With appWord
      .Documents.Add DocumentType:=wdNewBlankDocument
'      .Visible = True
      .Selection.PasteExcelTable LinkedToExcel:=False, WordFormatting:=False, RTF:=False
      .Selection.HomeKey Unit:=wdStory, Extend:=wdExtend
      DoEvents
      .Selection.Copy
   End With

   ' copy to new workbook
   Set wbkTo = Excel.Application.Workbooks.Add
   wbkTo.Worksheets(1).Range(sAddress).Select
   wbkTo.ActiveSheet.Paste
   DoEvents

   ' close Word
   appWord.Quit SaveChanges:=False

   MsgBox "Done."

End Sub

注意：这不会 100% 正确地复制格式，但对于大多数情况来说，它可能已经足够好了。在下面的示例中，我将 3 种条件格式应用于左侧表格中的第 1-9 行。右边的表格是运行的结果 CopyConditionalFormattingThruWord sAddress:="B3"。

运行上述代码的示例

Excel 2010： 如果您使用的是 Excel 2010，并且不想使用 Word，则可以使用范围的新DisplayFormat成员跳过 FormatCondition 测试。从帮助文件：

更改范围的条件格式或表格样式等操作可能会导致当前用户界面中显示的内容与 Range 对象的相应属性中的值不一致。使用 DisplayFormat 对象的属性返回在当前用户界面中显示的值。

您仍然必须手动分配其Borders, Font, Interior, &NumberFormat等中的值。

于 2012-05-02T17:40:18.977 回答
0

这是你正在尝试的吗？

我假设您只检查一个条件。我没有做任何错误处理。希望你也能照顾好它。

Option Explicit

Sub Sample()
    Dim ws As Worksheet, newws As Worksheet

    Set ws = Sheets("Sheet1")
    Set newws = Sheets("Sheet2")

    '~~> Area Mgr Store Metrics
    ws.Range("rngAreaMetricDetail").Copy

    newws.Activate

    '~~> Paste Values
    Range("V3").PasteSpecial xlPasteValues

    Selection.Interior.ColorIndex = GetColor(Range("rngAreaMetricDetail"))
End Sub

Public Function GetColor(rng As Range)
    Dim oFC As FormatCondition

    Set rng = rng(1, 1)
    If rng.FormatConditions.Count > 0 Then
        For Each oFC In rng.FormatConditions
            GetColor = oFC.Interior.ColorIndex
            Exit For
        Next oFC
    End If
End Function
于 2012-05-02T14:33:08.937 回答
0

试试这个代码......我有时使用的旧代码。我不得不做一些事情来让它对你有好处。

Sub move()
Dim lrow As Long
Dim lrow2 As Long
Dim rng As Range

Sheets(3).Cells.Clear


With Sheets(1)
    lrow = .Cells(Rows.Count, 1).End(xlUp).Row
    Set rng = Range(.Cells(2, 1), .Cells(lrow, 9))
    rng.Copy Sheets(3).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
End With

With Sheets(3)
    lrow = .Cells(Rows.Count, 1).End(xlUp).Row
    Set rng = Range(.Cells(2, 1), .Cells(lrow, 9))
    rng.Interior.Color = vbYellow
End With

With Sheets(2)
    lrow = .Cells(Rows.Count, 1).End(xlUp).Row
    Set rng = Range(.Cells(2, 1), .Cells(lrow, 9))
    rng.Copy Sheets(3).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
End With

With Sheets(3)
    lrow2 = .Cells(Rows.Count, 1).End(xlUp).Row
    Set rng = Range(.Cells(lrow2 - (lrow - 2), 1), .Cells(lrow2, 9))
    rng.Interior.Color = vbRed
End With

End Sub
于 2016-12-30T02:20:47.270 回答