使用VBA将多Excel区域复制到Outlook时出现#div/0!错误求助

问题描述 #

使用Ron de Bruin的VBA代码将两个Excel工作表区域合并到新建工作表，再生成Outlook邮件内容时，其中一个表格显示#DIV/0!错误，问题出在以下复制区域的代码段：

Worksheets("Data1").Range("A2:I29").Copy Destination:=Worksheets(ws1.Name).Range("A1")
Worksheets("DV2").Range("A2:I30").Copy Destination:=Worksheets(ws1.Name).Range("A35")
LastRow = Worksheets(ws1.Name).Cells(Rows.Count, 1).End(xlUp).Offset(1).Row

问题原因 #

使用Copy Destination会默认复制单元格的公式+值+格式，当原区域的公式引用了其他工作表或未复制到新表的单元格时，新工作表中无法找到引用对象，就会触发#DIV/0!这类计算错误。后续RangetoHTML函数的粘贴值操作无法回溯修正这个错误。

解决方案 #

修改复制逻辑，直接粘贴值+格式到新工作表，避免公式引用问题：

修改后的核心复制代码段

Set ws1 = ActiveWorkbook.Sheets.Add
' 复制Data1区域，仅粘贴值和格式
Worksheets("Data1").Range("A2:I29").Copy
With ws1.Range("A1")
    .PasteSpecial Paste:=xlPasteValues ' 粘贴静态值
    .PasteSpecial Paste:=xlPasteFormats ' 保留原格式
End With
' 复制DV2区域，仅粘贴值和格式
Worksheets("DV2").Range("A2:I30").Copy
With ws1.Range("A35")
    .PasteSpecial Paste:=xlPasteValues
    .PasteSpecial Paste:=xlPasteFormats
End With
Application.CutCopyMode = False ' 清除复制状态
LastRow = ws1.Cells(Rows.Count, 1).End(xlUp).Offset(1).Row
Set rng = ws1.UsedRange

完整修改后的代码

Sub Mail_Selection_Range_Outlook_Body()
    Dim dv As Range
    Dim sfr As Range
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    Dim ws1 As Worksheet ' 声明ws1类型，避免变体类型

    Set dv = Nothing
    Set sfr = Nothing
    Set rng = Nothing
    On Error Resume Next
    Set ws1 = ActiveWorkbook.Sheets.Add
    ' 复制Data1区域，粘贴值和格式
    Worksheets("Data1").Range("A2:I29").Copy
    With ws1.Range("A1")
        .PasteSpecial Paste:=xlPasteValues
        .PasteSpecial Paste:=xlPasteFormats
    End With
    ' 复制DV2区域，粘贴值和格式
    Worksheets("DV2").Range("A2:I30").Copy
    With ws1.Range("A35")
        .PasteSpecial Paste:=xlPasteValues
        .PasteSpecial Paste:=xlPasteFormats
    End With
    Application.CutCopyMode = False
    LastRow = ws1.Cells(Rows.Count, 1).End(xlUp).Offset(1).Row
    Set rng = ws1.UsedRange
    On Error GoTo 0

    If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected." & _
            vbNewLine & "Please correct and try again.", vbOKOnly
        Exit Sub
    End If
   
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
    With OutMail
        .To = ""
        .CC = ""
        .BCC = ""
        .Subject = ""
        .HTMLBody = RangetoHTML(rng)
        .Display
    End With
    On Error GoTo 0

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing
   
    Application.DisplayAlerts = False
    Sheets(ws1.Name).Delete
    Application.DisplayAlerts = True
   
End Sub

Function RangetoHTML(rng As Range)
    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:=8 ' 粘贴列宽
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

    With TempWB.PublishObjects.Add( _
        SourceType:=xlSourceRange, _
        Filename:=TempFile, _
        Sheet:=TempWB.Sheets(1).Name, _
        Source:=TempWB.Sheets(1).UsedRange.Address, _
        HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
        "align=left x:publishsource=")

    TempWB.Close savechanges:=False

    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

补充说明 #

• 新增了ws1的类型声明，让代码更严谨，避免变体类型潜在问题
• 清除CutCopyMode状态，防止Excel保持复制选中状态
• 仅粘贴值和格式，确保新工作表中没有依赖外部的公式，彻底避免计算错误

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