Mail a different files to each person in a range

[zlotajesien]

Hello
I've found this macro on a great website
http://www.rondebruin.nl/mail/folder2/files.htm

--------------------------------------------

Make a list in Sheet("Sheet1") with
In column A : Names of the people
In column B : E-mail addresses
In column C : Filenames like this C:\Data\Book2.xls (don't have to be
Excel files)

The Macro will loop through each row in Sheet1 and if there is a E-mail
address
and a filename that exist in that row it will create a mail with this
information and send it.


Sub TestFile()
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim cell As Range

Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")

On Error GoTo cleanup
For Each cell In
Sheets("Sheet1").Columns("B").Cells.SpecialCells(xlCellTypeConstants)
If cell.Offset(0, 1).Value <> "" Then
If cell.Value Like "?*@?*.?*" And Dir(cell.Offset(0,
1).Value) <> "" Then
Set OutMail = OutApp.CreateItem(olMailItem)
With OutMail
.To = cell.Value
.Subject = "Testfile"
.Body = "Hi " & cell.Offset(0, -1).Value
.Attachments.Add cell.Offset(0, 1).Value
.Display 'Or use Display
End With
Set OutMail = Nothing
End If
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub

--------------------------------------------------

but there is one problem for me i would like to send few files to one
person not only one file. How should I change the macro to do this.
File names will be in column C,D,E,F.
Thank you for solving my problem.

Kind Regards
Wano

 

[Ron de Bruin]

Hi

Try this one

Sub TestFile1()
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim cell As Range, FileCell As Range

Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")

On Error GoTo cleanup
For Each cell In Sheets("Sheet1").Columns("B").Cells.SpecialCells(xlCellTypeConstants)
If cell.Offset(0, 1).Value <> "" Then
If cell.Value Like "?*@?*.?*" Then
Set OutMail = OutApp.CreateItem(olMailItem)
With OutMail
.To = cell.Value
.Subject = "Testfile"
.Body = "Hi " & cell.Offset(0, -1).Value

For Each FileCell In Sheets("Sheet1").Cells(cell.Row, 1).Range("C1:F1") _
.SpecialCells(xlCellTypeConstants)
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
Next FileCell

.Display 'Or use Display
End With
Set OutMail = Nothing
End If
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub

 

[Ron de Bruin]

I update the site with a new macro
Please test it and post back if it is working OK for you

http://www.rondebruin.nl/mail/folder2/files.htm

 

[Ron de Bruin]

Hi

I made a small change to avoid that the macro stop when there is one row without a file name

Sub TestFile()
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim cell As Range, FileCell As Range

Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")

On Error GoTo cleanup
For Each cell In Sheets("Sheet1").Columns("B").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*@?*.?*" And Application.WorksheetFunction.CountA( _
Sheets("Sheet1").Cells(cell.Row, 1).Range("C1:F1")) > 0 Then
Set OutMail = OutApp.CreateItem(olMailItem)
With OutMail
.To = cell.Value
.Subject = "Testfile"
.Body = "Hi " & cell.Offset(0, -1).Value

'Enter the file names in the C:F column in each row
'You can make the range bigger if you want, only change the column not the 1
For Each FileCell In Sheets("Sheet1").Cells(cell.Row, 1).Range("C1:F1") _
.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell

.Send 'Or use Display
End With
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub

 

[zlotajesien]

Ron de Bruin napisal(a):

Hi

I made a small change to avoid that the macro stop when there is one row without a file name
.....
Sub TestFile()
.....
End Sub

Hi
Works PERFECT.
You're genius. Now I save some time and few mistakes.
Thank you. You helped me a lot.

Wano

 

[Ron de Bruin]

You are welcome

Thanks for the feedback