Question

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

我不需要的一件事是复制创建着色的条件格式。我只想要范围内各种细胞的最终颜色。

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

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

提前完成。

Answer 1

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

检查每个单元格上是否使用了FormatCondition。
手动分配FormatCondition中的格式。（Borders，Font，Interior，＆amp; 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"的结果。

example of running the above code

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

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

您仍然需要手动分配Borders，Font，Interior和＆amp; NumberFormat等。

Answer 2

这是你在尝试的吗？

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

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

Answer 3

试试这个代码...我有时使用的旧代码。我必须做很多事情才能让它变得更好。

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

复制和粘贴值 - 着色

3 个答案: