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.SpecialC ells(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

--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm


"Ron de Bruin" wrote in message ...
Hi Celeste

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

--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm


"u473" wrote in message ups.com...
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