ExcelBanter

ExcelBanter (https://www.excelbanter.com/)
-   Excel Worksheet Functions (https://www.excelbanter.com/excel-worksheet-functions/)
-   -   Mail a different files to each person in a range (https://www.excelbanter.com/excel-worksheet-functions/43510-mail-different-files-each-person-range.html)

[email protected]
Mail a different files to each person in a range
 
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(x lCellTypeConstants)
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(x lCellTypeConstants)
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




--
Regards Ron de Bruin
http://www.rondebruin.nl


wrote in message ups.com...
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(x lCellTypeConstants)
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
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



--
Regards Ron de Bruin
http://www.rondebruin.nl


"Ron de Bruin" wrote in message ...
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(x lCellTypeConstants)
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




--
Regards Ron de Bruin
http://www.rondebruin.nl


wrote in message ups.com...
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(x lCellTypeConstants)
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

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(x lCellTypeConstants)
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



--
Regards Ron de Bruin
http://www.rondebruin.nl


"Ron de Bruin" wrote in message ...
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



--
Regards Ron de Bruin
http://www.rondebruin.nl


"Ron de Bruin" wrote in message ...
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(x lCellTypeConstants)
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




--
Regards Ron de Bruin
http://www.rondebruin.nl


wrote in message ups.com...
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(x lCellTypeConstants)
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

[email protected]

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



--
Regards Ron de Bruin
http://www.rondebruin.nl



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



--
Regards Ron de Bruin
http://www.rondebruin.nl


wrote in message ups.com...

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



--
Regards Ron de Bruin
http://www.rondebruin.nl



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

Wano


All times are GMT +1. The time now is 11:01 AM.

Powered by vBulletin® Copyright ©2000 - 2025, Jelsoft Enterprises Ltd.
ExcelBanter.com