Do you have duplicate rows with the same mail addresss in B ?
Am I understand you correct ?

--

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


wrote in message ...
Hi there!

I have this Excel Macros which is designed to send an attachment to
someone's e-mail address. In this case, the title of the attachment is
identical to the name of the person to who I am sending it to.

My active worksheet only uses two ranges, A and B. Down column A
lists the names of people; each cell in column A contains one person's
name. Down Column B lists each person's corresponding e-mail address;
each cell in column B contains one e-mail address. The code below
works just fine for that.

Unfortunately, there may be more than one e-mail addresses contained
in each B cell. Any suggestions?

Sub SendEmailWithAttachment()
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim strEmail As String, strName As String
Dim lRowCount As Long


Set objOutlook = CreateObject("outlook.application") ' Start
outlook


lRowCount = 2 ' Change to starting ROW containing email address/
name


Do Until ActiveSheet.Cells(lRowCount, 2) = "" ' check for email,
End if none found
strEmail = ActiveSheet.Cells(lRowCount, 2).Value ' get email
address
strName = ActiveSheet.Cells(lRowCount, 1).Value ' get client name
Set objOutlookMsg = objOutlook.CreateItem(olMailItem) ' create
new email msg
With objOutlookMsg ' Fill email


.Subject = "Put this text in subject line" ' Note: Could be
column "C" - ActiveSheet.Cells(lRowCount, 3).Value
.Body = "Put this text in body of email" ' Note: Could be
column "D" - ActiveSheet.Cells(lRowCount, 4).Value

.To = strEmail
.Attachments.Add ("c:/e-mail attachments/" & strName & ".xls")
.Send
End With
lRowCount = lRowCount + 1 ' Increment Row Counter
Loop


objOutlook.Quit
Set objOutlook = Nothing
Set objOutlookMsg = Nothing
End Sub