复制工作表条件格式丢失及VBA导出表格字体异常问题咨询

一、复制工作表时完整保留条件格式的方法 #

• 优先用工作表整体复制：直接复制整个工作表到新工作簿，这是最稳妥的方式，能完整保留所有条件格式、数据验证、公式引用等设置。代码示例：

  Sheets("原工作表名称").Copy After:=Workbooks("新建工作簿.xlsx").Sheets(1)
  

• 如果只复制特定区域：粘贴时使用xlPasteAllMergingConditionalFormats参数，这个选项会合并源区域的条件格式到目标区域，同时保留所有格式规则。注意要确保原区域的条件格式规则没有引用其他无关工作表的内容，避免在新工作簿中规则失效。

二、解决VBA复制到Outlook后字体全红的问题 #

你的问题出在当前的RangetoHTML函数里——分开粘贴值和格式的方式破坏了条件格式的动态逻辑，xlPasteFormats把条件格式触发时的红色字体当成了静态格式直接应用，导致所有单元格都显示红色。下面是修改后的函数，能正确保留条件格式的动态效果：

Function RangetoHTML(rng As Range)
    If rng Is Nothing Then Exit Function
    
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    
    TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    
    ' 复制区域并创建临时工作簿
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        ' 粘贴全部内容（包括条件格式、值、格式规则）
        .Cells(1).PasteSpecial Paste:=xlPasteAll
        Application.CutCopyMode = False
        
        ' 删除绘图对象（保留原逻辑）
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
    
    ' 保存为HTML文件（补充原代码缺失的关键步骤）
    TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic).Publish (True)
    
    ' 读取HTML内容
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.ReadAll
    ts.Close
    TempWB.Close SaveChanges:=False
    Kill TempFile
End Function

修改说明： #

1. 把原来分开的xlPasteValues、xlPasteFormats改成了xlPasteAll，完整复制源区域的条件格式规则，避免格式被静态化。
2. 补充了原代码缺失的“将临时工作簿发布为HTML”步骤，这是生成Outlook可识别的动态格式的关键。
3. 保留了删除绘图对象的逻辑，避免邮件中出现多余图形元素。

另外建议你检查原工作表的条件格式规则：

• 确认“停止如果为真”的设置是否合理，避免规则冲突导致格式异常。
• 确保规则中的单元格引用是相对引用（比如A1而非Sheet1!A1），这样复制到新工作簿后规则能正确应用到目标区域。

内容的提问来源于stack exchange，提问作者charlie