Macro Running very slow

[Seanie]

I have the code below which takes about 25 mins to run, all it does is
extract sheets from another file and e-mails them out, it used to take
only 5-6 mins, I don't know why it has now exploded in time, I've even
turned calculations to manual, the file size of the source hasn't
increased in size, I've turned calculations on this to manual also.
Code ex Ron De Bruin. Anyone any suggestions. Could it be any virus, I
use AVG server, although have always used this even when it only took
5-6 mins

Sub Mail()
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim Sh As Worksheet
Dim strbody As String

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

Set Sourcewb = ActiveWorkbook

Application.Calculation = xlCalculationManual

'Copy the sheets to a new workbook
Sourcewb.Sheets(Array("Sales", "Hours", "Current", "PvL", "AvL",
"Comments", "Excess")).Copy
Set Destwb = ActiveWorkbook

'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007
'We exit the sub when your answer is NO in the security
dialog that you only
'see when you copy a sheet from a xlsm file with macro's
disabled.
If Sourcewb.Name = .Name Then
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Your answer is NO in the security dialog"
Exit Sub
Else
FileExtStr = ".xlsx": FileFormatNum = 51

End If
End If
End With

' 'Change all cells in the worksheets to values if you want
' For Each sh In Destwb.Worksheets
' sh.Select
' With sh.UsedRange
' .Cells.Copy
' .Cells.PasteSpecial xlPasteValues
' .Cells(1).Select
' End With
' Application.CutCopyMode = False
' Destwb.Worksheets(1).Select
' Next sh

'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & "\"
TempFileName = "Part of " & Sourcewb.Name & " " & Format(Now, "dd-
mmm-yy h-mm") & "~"

ActiveWindow.TabRatio = 0.908


Sheets("Sales").Activate
Range("A1").Select


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

For Each cell In ThisWorkbook.Sheets("Current").Range("BF2:BF35")
strbody = strbody & cell.Value & vbNewLine
Next

For Each cell In ThisWorkbook.Sheets("Current") _
.Columns("BB").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*@?*.?*" Then
strto = strto & cell.Value & ";"
End If
Next
strto = Left(strto, Len(strto) - 1)

With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr,
FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.To = ""
.CC = ""
.BCC = strto
.Subject =
ThisWorkbook.Sheets("Current").Range("BA1").Value
.Body = strbody
.Attachments.Add Destwb.FullName
.ReadReceiptRequested = True
If Sheets("Current").Range("D192").Value > 0 Then
.Importance = 2
Else
.Importance = 1
End If
.SendUsingAccount = OutApp.Session.Accounts.Item(3)
.Send
End With
On Error GoTo 0
.Close savechanges:=False
End With

'Delete the file you have send
Kill TempFilePath & TempFileName & FileExtStr

Set OutMail = Nothing
Set OutApp = Nothing

End Sub

 

[Ron de Bruin]

Hi Seanie

Send me your workbook private and I try to reproduce it

 

[Seanie]

Hi Seanie

Send me your workbook private and I try to reproduce it

Thanks Ron, its a fairly confidential file so I'll have to see if I
can extract safely first

 

[Seanie]

there are two things that may be causing the probelm

1) Do you have a delay of around 45 seconds when you open any of the
Microsoft Produccts including excel.  the file system Indexing may have
been truned on which caused delays in opening excel.  I know how to fix
this problem.

2) Did you change anything on your PC like upgrade to Office 2008, or
changed from From XP to either Vista or windows 7?  Office 2008 is much
slower than 2003.  Microsft was working on some fixes.  so make sure you
have all the latest upgrades.

3) Your may have a memory problem on your PC or a hard disk Problem.
Your hard Drive could be fragmented or running out of space.  run a
speed disk utility to fix the hard drive.  You may also be low on your
temp folder on your PC.  Delete any temp file you don't need and your
Waste Basket.

Thanks Joel

On (1) not 45 seconds everytime, but certainly sometimes, how can I
check the indexing

On (2) Running Office 2007 on Windows Server 2003, have all available
updates

On (3) How can I check the temp folder and then clear it? I run
Terminal Services, so all runs on the server, no hard disk space issue
on this (its just a recent new disk installed, but had the problem
prior, so can't see fragmentation the issue)