Looping Problems

[chefdt]

I have a pice of code to email a sheet in a workbook. It works great. When I try to add a loop to email all the sheets, I either get just the first sheet, or x number of copies of the first sheet depending on how many sheets. What am I missing?

I'm also reformatting A2 into an email address. It will contain a name.


Sub Email_Sheet()


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


For Each WS In ThisWorkbook.Sheets




With WS

'Turn off screen updating
Application.ScreenUpdating = False



'Format Email Address in A2. Can change to any cell.
ActiveSheet.Range("A2").Select
ActiveCell.Replace What:=", ", Replacement:=".", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=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 A TEST"
'.body = "This is the body of the message." & 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

End With
Next









End Sub

 

[amisagi]

Hi - I might be wrong... perhaps activating the main workbook before looping the next would help.
Suggest:

[COLOR=#574123]Dim oApp As Object[/COLOR]
[COLOR=#574123]Dim oMail As Object[/COLOR]
[COLOR=#574123]Dim LWorkbook As Workbook[/COLOR]
[COLOR=#574123]Dim LFileName As String[/COLOR]
[COLOR=#574123]Dim WS As Worksheet
[/COLOR]
[B]Dim MainSheet as Workbook[/B]

Set MainSheet = Activeworkbook [COLOR=#008000]'This being your main sheet...

[/COLOR][COLOR=#574123]For Each WS In Mainsheet.Sheets

[/COLOR][COLOR=#574123]With WS[/COLOR]

[COLOR=#574123]'Turn off screen updating[/COLOR]
[COLOR=#574123]Application.ScreenUpdating = False
[/COLOR]...
...

[COLOR=#574123]Set oApp = Nothing[/COLOR]

[COLOR=#574123]End With

[B]MainSheet.Activate[/B]
[/COLOR]
[COLOR=#574123]Next[/COLOR]

Hope this helps... if i am wrong, feedback will be welcome

 

[ukmikeb]

Hi

This line

LFileName = LWorkbook.Worksheets(1).Name

is selecting the first worksheet.

Changing it to :-

LFileName = LWorkbook.ws.Name

should solve your problem.

hth

 

[chefdt]

Got this strange error...

Dialog box about "unable to use "flash Fill tool"

Hi

This line

LFileName = LWorkbook.Worksheets(1).Name

is selecting the first worksheet.

Changing it to :-

LFileName = LWorkbook.ws.Name

should solve your problem.

hth

 

[ukmikeb]

Go back to the previous version of that line,

After you close LWorkBook, Set LWorkbook = Nothing

hth

 

[chefdt]

I get an OBJECT REQUIRED error on the LWorkbook=Nothing

Go back to the previous version of that line,

After you close LWorkBook, Set LWorkbook = Nothing

hth

Sub Email_Sheet()




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




For Each WS In ThisWorkbook.Sheets






'Turn off screen updating
Application.ScreenUpdating = False






'Format Email Address in A2. Can change to any cell.
ActiveSheet.Range("A2").Select
ActiveCell.Replace What:=", ", Replacement:=".", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=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 A TEST"
'.body = "This is the body of the message." & 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
LWorkbook = Nothing




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




Next

 

[ukmikeb]

Hi

That line should have been :-

Set LWorkbook = Nothing

but I don't think it matters if it is absent.

I tried creating the files (in Excel 2007) without the e-mail part and they create successfully with one worksheet per file.

I have not been able to create the e-mail which may be due to a missing reference.

Fwiw I moved the line

LFileName = LWorkbook.Worksheets(1).Name

to just after

For Each WS In ThisWorkbook.Sheets

changing it to

LFileName = WS.Name

I note in your last quote of the full code you are missing the End With statement before the Next statement.