Folks, I inherited the following script that creates and formats an excel document, then e-mails it. I'm not sure how old it is, but it takes an unusually long time to run (40-45 seconds per sheet). Since I can see the sheet being created quickly, I believe the time trap is in the e-mail section of the script. Any suggestions for streamlining that portion (bolded)?
Sub CreateAndEmailWorkbooks()
'
'
On Error GoTo Error_Handler
Dim str As String
Dim app As Excel.Application
Dim ws As Excel.Worksheet
Dim wb As Excel.Workbook
Dim row As Long
Dim vendornum As Long
Dim rslip As Excel.RoutingSlip
Dim email As String
Dim venconfn As String
Dim efname As String
Dim eraddr As String
Dim catman As String
Dim repyr As String
Dim repmon As String
Dim cmname As String
Dim intResult As Integer
Dim FilePath As String
Dim intFilesSaved As Integer
Dim intFilesEmailed As Integer
Dim strSubject As String
intResult = vbNo
FilePath = ThisWorkbook.Path & "\Reports\"
MkDir FilePath
Set app = New Application
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Vendors")
wb.Worksheets("Vendors").Activate
strSubject = wb.Worksheets("Notes").Cells(27, 7)
For row = 2 To 65000
If IsNumeric(Cells(row, 1)) = True And Cells(row, 1) <> "" Then
vendornum = Cells(row, 1)
email = ""
If Cells(row, 3) <> "" Then
email = Cells(row, 3)
email2 = Cells(row, 24)
catman = Cells(row, 21)
venconfn = Cells(row, 19)
cmname = Cells(row, 20)
efname = Cells(row, 7)
eraddr = Cells(row, 9)
repyr = Cells(row, 22)
repmon = Cells(row, 23)
End If
wb.Worksheets("Scorecard").Cells(10, 2) = vendornum
str = wb.Worksheets("Scorecard").Cells(8, 2)
Dim newBook As Workbook
Dim wks As Worksheet
Set newBook = Workbooks.Add
wb.Worksheets("Scorecard").Activate
wb.Worksheets("Scorecard").Cells.Select
wb.Worksheets("Scorecard").Cells.Copy
newBook.Worksheets("Sheet1").Activate
newBook.Worksheets("Sheet1").Cells.Select
Set wks = newBook.Worksheets("Sheet1")
wks.Paste
wks.Cells.PasteSpecial xlPasteValuesAndNumberFormats, xlPasteSpecialOperationNone, False, False
With newBook.ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = "$B:$C"
End With
newBook.ActiveSheet.PageSetup.PrintArea = "$A$6:$Q$66"
With newBook.ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = "&""Arial,Bold""PROCESS"
.CenterFooter = ""
.RightFooter = "&8Created by: SCM PDT &D" & Chr(10) & "&F"
.LeftMargin = Application.InchesToPoints(0)
.RightMargin = Application.InchesToPoints(0)
.TopMargin = Application.InchesToPoints(0.36)
.BottomMargin = Application.InchesToPoints(0.48)
.HeaderMargin = Application.InchesToPoints(0.18)
.FooterMargin = Application.InchesToPoints(0.24)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = True
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperLetter
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 55
.PrintErrors = xlPrintErrorsDisplayed
End With
wks.Rows("52:54").Select
wks.Rows("52:54").Delete xlUp
wks.Rows("1:5").Select
wks.Rows("1:5").Delete xlUp
wks.Range("B8:B9").Select
With newBook
.SaveAs Filename:=FilePath & repyr & "-" & repmon & " - " & str & " - " & vendornum & ".xls", FileFormat:=xlAddIn
intFilesSaved = intFilesSaved + 1
If intResult = vbNo Then
If email <> "" Then
Set Message = CreateObject("CDO.Message")
' Make a copy of the current Excel document in the temp folder so we can add as attachment
AttachmentFile = Environ("temp") & Application.PathSeparator & ActiveWorkbook.Name
ActiveWorkbook.SaveCopyAs AttachmentFile
With Message
.Subject = "Monthly Scorecard"
.From = eraddr
.To = email
.Cc = email2
.htmlbody = "Dear " & venconfn & ", " & "<BR>" & "<BR>" & "Attached is your monthly Scorecard. If you have any questions concerning the scores, please reach out to your contact to discuss. " & "<BR>" & "<BR>" & " Best Regards, " & "<BR>" & efname
.AddAttachment (AttachmentFile) 'Add the copy as an attachemnt
With .Configuration.Fields ' Configure the remote SMTP server.
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gfs.com"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.Update
End With
.send
End With
Kill AttachmentFile 'Delete the copy
End If
.Close
Set newBook = Nothing
Set wks = Nothing
End If
wb.Worksheets("Vendors").Activate
End With
End If
Next
If intResult = vbNo Then
MsgBox intFilesSaved & " Files Have Been Saved To:" & FilePath & vbLf & _
intFilesEmailed & " Files Have Been Emailed.", vbOKOnly, "Macro Results"
Else
MsgBox intFilesSaved & " Files Have Been Saved To:" & FilePath & vbLf & _
"File Delivery Via Email Disabled.", vbOKOnly, "Macro Results"
End If
Set app = Nothing
Exit Sub
Error_Handler:
Debug.Print Err.Number
Select Case Err.Number
Case 75
Resume Next
Case 1004
MsgBox "You must be connected to the company Network in order to email the Files.", vbOKOnly + vbInformation, "EMAIL ERROR"
intResult = MsgBox("Disable automatic emailing? This is recommended.", vbYesNo + vbQuestion, "DISABLE EMAILING")
Resume Next
Case Is <> 1004
MsgBox Err.Number & " " & Err.Description
End Select
End Sub