E-mail Each WorkSheet in collection to pertaining Manager

U

u473

I receive a monthly workbook with 30+ worksheets with Projects tab
names like 51693, 52231. 61121, etc...
I have a separate workbook named Email with one worksheet containing
those Project Tab names in the first column, and adjacent columns with
pertaining Manager Name and E-mail address as follows :
Project Manager Email
51693 Steve (e-mail address removed)
52231 Rick (e-mail address removed)
Etc...

I need to E-mail each individual worksheet as a separate workbook to
each pertaining manager,
and save this new workbook in my Projects folder, under the original
tab name like : C:\Projects\51693.xls

The logic sequence is as follows :

Sub ForEachWS()

Dim ws as Worksheet

For Each ws in Worksheets
' Email this workbook to pertaining Manager in Workbook, But
what is the syntax ?
' Save Workseet as new workbook
Next ws
End Sub

Can you help me,
Thank you,
Celeste
 
G

Guest

You're going to want to mail it after you've saved the sheet as a new book,
because you can only attach an entire file to an e-mail, not just certain
sheets. You can turn on the macro recorder, right click a sheet, Choose Move
or Copy, select the create a copy checkbox, choose New Book from the To Book
drop down, then "Save As" this new book with a name of your choosing. Then
stop the macro recorder and review the code it created.

To automate this, you will need a variable for the new book's filename. I'm
assuming you can populate this from the columns that contain the manager's
name, project, or combination of the two.

To mail the workbook, try:

ActiveWorkbook.SendMail recipients:="(e-mail address removed)"

So you might need another variable for the e-mail address, the value for
which would also come from one of your cells. Then you might code, for
example:

MyEmail = Range("A1").value
ActiveWorkbook.SendMail recipients:=MyEmail

You will also need to loop through all the sheets you wish to do this for.

So maybe:

For Each S in Sheets
If S.Name <> SheetToNotMail And S.Name <> 2ndSheetToNotMail Then
Code for creating the file, naming it, mailing it, closing it.
End if
Next S

One other thing to remember is that security software may pop up a box each
time the program tries to mail one of the sheets, asking you to confirm that
you intended this to happen. This is because computer viruses often use
e-mail programs to distribute themselves around the world. So you would have
to press "OK" or some such button once for each file you were mailing. I
don't think you want to try to disable such a feature for obvious reasons.
And it would still be much better than doing all this manually.

Hope this helps.

Keith
 
U

u473

I do appreciate your help.
The answer I retrieved from My Microsoft Outlook Help is : Microsoft
Office Oulook 2007
part of Microsoft Office Professional Plus 2007. Does that answer
your question ?
Thank you again,
Celeste
 
R

Ron de Bruin

Hi Celeste

Copy the macro in a module of the workbook named Email with one worksheet containing
those Project Tab names in the first column, and adjacent columns with
pertaining Manager Name and E-mail address

Now open the data workbook with 30 tabs and be sure that this workbook is active
Note: there is no good error checking in this macro on this moment so be sure that the sheet name is correct

With the data workbook active use Alt-F8 to run the macro
Test it first with a few sheets in the list

I display the mail on this moment so you can see if it is correct
If it is OK then change it to .Send
..Display 'or use .Send

We can add better error checking but test this one first

Sub Mail_Every_Worksheet_In_List()
'Working in 2000-2007
Dim sh As Worksheet
Dim Wb As Workbook
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
Dim WbData As Workbook
Dim cell As Range

TempFilePath = Environ$("temp") & "\"

If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007
FileExtStr = ".xlsm": FileFormatNum = 52
End If

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

Set WbData = ActiveWorkbook
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon

For Each cell In ThisWorkbook.Sheets(1).Columns("C").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*@?*.?*" Then

WbData.Worksheets(CStr(cell.Offset(0, -2).Value)).Copy
Set Wb = ActiveWorkbook

TempFileName = "Sheet " & cell.Offset(0, -2).Value & " of " _
& WbData.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")

Set OutMail = OutApp.CreateItem(0)
With Wb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.To = cell.Value
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.Body = "Hi " & cell.Offset(0, -1).Value & vbNewLine & vbNewLine & _
"Here is the file you..................."

.Attachments.Add Wb.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Display 'or use .Send
End With
On Error GoTo 0
.Close SaveChanges:=False
End With
Set OutMail = Nothing

Kill TempFilePath & TempFileName & FileExtStr
End If
Next cell

Set OutApp = Nothing

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
 
U

u473

Hi Ron,
I launched the macro with Alt-F8 from the active workbook named
WorkbookTest
where 3 small worksheets are residing : 74153, 64001, 61263 (Not in
sequential order. Do they have to ?)
I got the following error : Run-time error '9' Subscript out of range
on : WbData.Worksheets(CStr(cell.Offset(0, -2).Value)).Copy
I cannot figure what's in error.
I put a MsgBox ThisWorkbook.Name to verify at that point that I was
indeed in the Email Workbook

Note : MsgBox WbData.Worksheets(CStr(cell.Offset(0, -1).Value)) gives
me the same error.
I also tried to have the Project Names formatted in the Email workbook
as Number or Text. That did not change the error.
Thank you again for your help.
Celeste
 
R

Ron de Bruin

Hi Celeste

Send me your two workbooks private
I will look at it for you then
 
R

Ron de Bruin

You have two worksheets that have a space before the sheet name

Use this one (copy also the function) to avoid the error

Sub Mail_Every_Worksheet_In_List()
'Working in 2000-2007
Dim sh As Worksheet
Dim WB As Workbook
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
Dim WbData As Workbook
Dim cell As Range
Dim Sstr As String

TempFilePath = Environ$("temp") & "\"

If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007
FileExtStr = ".xlsm": FileFormatNum = 52
End If

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

Set WbData = ActiveWorkbook
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon

For Each cell In ThisWorkbook.Sheets(1).Columns("C").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*@?*.?*" Then

Sstr = cell.Offset(0, -2).Value
If SheetExists(Sstr, WbData) = False Then
' Worksheet not exist
Else

WbData.Worksheets(Sstr).Copy
Set WB = ActiveWorkbook

TempFileName = "Sheet " & cell.Offset(0, -2).Value & " of " _
& WbData.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")

Set OutMail = OutApp.CreateItem(0)
With WB
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.To = cell.Value
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.Body = "Hi " & cell.Offset(0, -1).Value & vbNewLine & vbNewLine & _
"Here is the file you..................."

.Attachments.Add WB.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Display 'or use .Display
End With
On Error GoTo 0
.Close SaveChanges:=False
End With
Set OutMail = Nothing

Kill TempFilePath & TempFileName & FileExtStr
End If

End If
Next cell

Set OutApp = Nothing

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub


Function SheetExists(SName As String, _
Optional ByVal WB As Workbook) As Boolean
'Chip Pearson
On Error Resume Next
If WB Is Nothing Then Set WB = ThisWorkbook
SheetExists = CBool(Len(WB.Sheets(SName).Name))
End Function
 
G

Guest

I have a similar issue except I have multiple worksheets going to one
manager. Is there a way to create only one workbook with multiple worksheets
for each manager.
Ex:
51693 Steve (e-mail address removed)
52231 Rick (e-mail address removed)
52233 Rick (e-mail address removed)

Could 52231 and 52233 be in one workbook and sent to Rick?

Thanks,
Peggy
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Formatting issue when sending e-mail via CDO to Excel 2007 1
Split file, saving each tab/worksheet to a new workbook, w/tab asworkbook name? 4
e-mail subject name changing 1
Attache Excel Worksheet (Not Workbook) to Email 2
Macro to Email specific fields in a worksheet 1
Encourage users to enable macros 2
e-mail individual worksheet/tab w/out e-mailing entire workbook? 1
E-Mail Sheets Q 6

Top