Looping an Email Routine

[chefdt]

I have run this code successfully on a test sheet (sheet1, sheet2, sheet3), but when I plug it into my REAL project I get an error at the Activesheet.Copy line. Any thoughts?

Sub Email_Sheet()

Set wbook = ActiveWorkbook


    For Each sht In wbook.Worksheets
       sht.Activate
       sht.Range("A2").Select
       
      sht.Cells.Replace What:=", ", Replacement:=".", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False




Dim oApp As Object
Dim oMail As Object
Dim LWorkbook As Workbook
Dim LFileName As String




'Turn off screen updating
Application.ScreenUpdating = False




'Copy the active worksheet and save to a temporary workbook
ActiveSheet.Copy
Set LWorkbook = ActiveWorkbook




'Create a temporary file in your current directory that uses the name
' of the sheet as the filename
LFileName = LWorkbook.Worksheets(1).Name
On Error Resume Next
'Delete the file if it already exists
Kill LFileName
On Error GoTo 0
'Save temporary file
LWorkbook.SaveAs FileName:=LFileName




'Create an Outlook object and new mail message
Set oApp = CreateObject("Outlook.Application")
Set oMail = oApp.CreateItem(0)




'Set mail attributes (uncomment lines to enter attributes)
' In this example, only the attachment is being added to the mail message
With oMail
.To = Range("A2").Value & "@ok.sysco.com"
.Subject = "This is the Low Demand Report"
.Body = "Look at these Low Demand Items and Raise Your Paycheck. The OPCO sells less than 5 cases per week of these items!!" & vbCrLf & vbCrLf & _
"Attached is the file"
.Attachments.Add LWorkbook.FullName
.Send
End With




'Delete the temporary file and close temporary Workbook
LWorkbook.ChangeFileAccess Mode:=xlReadOnly
Kill LWorkbook.FullName
LWorkbook.Close SaveChanges:=False




'Turn back on screen updating
Application.ScreenUpdating = True
Set oMail = Nothing
Set oApp = Nothing


Next sht




End Sub