VBA：我怎样才能避免由于发布到htm文件而导致的速度缓慢？

我有一些代码，在运行时，选择一些单元格，删除这些单元格上的条件格式，但保留格式，然后将这些单元格转换为htm，以便可以在电子邮件中发送。我遇到的问题是，将工作表发布到htm文件的过程非常缓慢，而且我有很多电子邮件要发送，有没有办法克服这种缓慢

代码如下：

Sub EmailExtract()

Dim objOutlook As Object
Dim objMail As Object
Dim TempFilePath As String
Dim Location As String
Dim PrimaryNumber As String
Dim rng As Range
Dim PrimaryRecipients As String
Dim SecondaryRecipients As String
Dim To_Name As String
Dim Region As String


Worksheets("Contacts").Activate
Range("A2").Select
While ActiveCell <> ""

Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)

    ActiveCell.Offset(1, 0).Select
    PrimaryNumber = ActiveCell.Value
    To_Name = ActiveCell.Offset(0, 4).Value
    If To_Name = "" Or To_Name = "0" Then
        To_Name = ActiveCell.Offset(0, 7).Value
        If To_Name = "" Or To_Name = "0" Then
            MsgBox PrimaryNumber & " does not have a Manager with a first name."
            Exit Sub
        Else
            PrimaryRecipients = ActiveCell.Offset(0, 9).Value
            SecondaryRecipients = ActiveCell.Offset(0, 10).Value
        End If
    Else
        PrimaryRecipients = ActiveCell.Offset(0, 6).Value
        SecondaryRecipients = ActiveCell.Offset(0, 9).Value & ";" & ActiveCell.Offset(0, 10).Value
    End If


    Worksheets("Retailer Output 2").Activate
    Range("C2").Value = PrimaryNumber 



    ActiveWorkbook.Worksheets("Retailer Output 2").Copy _
   after:=ActiveWorkbook.Worksheets("Retailer Output 2")
    ActiveSheet.Name = "Without Formatting"

    Set rng = ActiveSheet.Range("A1:M28").Rows.SpecialCells(xlCellTypeVisible)
    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

    Keep_Format

    With objMail
            .To = PrimaryRecipients
            .Cc = SecondaryRecipients
            .Subject = ""

            Dim Greeting As String
            If Time >= #12:00:00 PM# Then
                Greeting = "Afternoon"
            Else
                Greeting = "Morning"
            End If

            Dim LastMonth As String
            LastMonth = MonthName((Month(Date)) - 1)

            .HTMLBODY = "<font face=Arial><p>" & "Good " & Greeting & " " & To_Name & "," & "</p>"
            .HTMLBODY = .HTMLBODY + "<p>" & "Please find below your " & LastMonth & " Information." & "</p>"
            .HTMLBODY = .HTMLBODY + RangetoHTML(rng)
            .Send
    End With
    Worksheets("Contacts").Activate
    Application.DisplayAlerts = False
    Sheets("Without Formatting").Delete
    Application.DisplayAlerts = True
Wend


Set objOutlook = Nothing
Set objMail = Nothing

Set objOutlook = Nothing
Set objMail = Nothing

End Sub

Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2013
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"

'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
    rng.Copy Destination:=.Cells(1)
    .Cells(1).Select
    On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
    On Error GoTo 0
End With

'Publish the sheet to a htm file
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

'Read all data from the htm file into RangetoHTML
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=")

'Close TempWB
TempWB.Close savechanges:=False

'Delete the htm file we used in this function
Kill TempFile

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

Function Keep_Format()
Dim ws As Worksheet
Dim mySel As Range, aCell As Range

'~~> Change this to the relevant sheet
Set ws = ThisWorkbook.Sheets("Without Formatting")
'~~> Change this to the relevant range
Set mySel = ws.Range("A1:M28")

For Each aCell In mySel
    With aCell
      .Font.FontStyle = .DisplayFormat.Font.FontStyle
      .Interior.Color = .DisplayFormat.Interior.Color
      .Font.Strikethrough = .DisplayFormat.Font.Strikethrough
    End With
Next aCell

mySel.FormatConditions.Delete

End Function

---

有人能帮我吗？

在代码开头添加

Application.ScreenUpdate=False

和

Application.DisplayAlerts=False

，最后将它们设置为True。这应该能帮助你在宏或函数中，在子函数的开头和结尾，都能做些什么。别忘了重新打开它！！！它可以防止在服务器上重新加载数据screen@Hearner我已经试过了，它确实帮了一点忙，但不是很忙。如果你想得到关于如何改进工作代码的建议，那就试试这个网站。严格地说，只有断开的代码才是如此。在代码的开头添加

Application.screenUpdate=False

和

Application.DisplayAlerts=False

，最后将它们设置为True。这应该能帮助你在宏或函数中，在子函数的开头和结尾，都能做些什么。别忘了重新打开它！！！它可以防止在服务器上重新加载数据screen@Hearner我已经试过了，它确实帮了一点忙，但不是很忙。如果你想得到关于如何改进工作代码的建议，那就试试这个网站。严格地说，只有坏代码才是如此。

 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