Mail distribution in Excel

[conte]

I have the following code to send an attacjment specified in a an excel cell to a list given in excel. Now I have a new project at work to modify this code to send all the files in a given folder. Each person in the list have a different set of files but each person's files are saved under the same folder.Each person has unique folder. How can I modify these codes to attach a group of file given a folder?
Your help is greatly appreciated.

Sub BenimOutlook()
Dim sht As Worksheet
Dim FirstRow As Integer
Dim LastRow As Integer
Dim SendTo As String, Esubject As String, Ebody As String
Dim MonOutlook As Object
Dim MonMessage As Object
Set sht = Worksheets("Sheet1&quot

FirstRow = 2
LastRow = 500
For x = FirstRow To LastRow Set MonOutlook = CreateObject("Outlook.Application&quot
Set MonMessage = MonOutlook.createitem(0)
Ebody = sht.Range("F" & x).Value
Esubject = sht.Range("E" & x).Value
SendTo = sht.Range("D" & x).Value
NewFileName = sht.Range("G" & x).Value
MonMessage.To = SendTo
MonMessage.Subject = Esubject
MonMessage.body = Ebody
MonMessage.Attachments.Add (NewFileName)
MonMessage.send
Set MonOutlook = Nothing
Set MonMessage = Nothing
Next x
End Sub

 

[chandlm]

Conte,

You could try something like this:(additional code in red)


Sub BenimOutlook()
Dim sht As Worksheet
Dim FirstRow As Integer
Dim LastRow As Integer
Dim SendTo As String, Esubject As String, Ebody As String, Folder As String

Dim MonOutlook As Object
Dim MonMessage As Object
Set sht = Worksheets("Sheet1&quot

FirstRow = 2
LastRow = 500
For x = FirstRow To LastRow
Set MonOutlook = CreateObject("Outlook.Application&quot
Set MonMessage = MonOutlook.createitem(0)
Ebody = sht.Range("F" & x).Value
Esubject = sht.Range("E" & x).Value
SendTo = sht.Range("D" & x).Value
Folder = sht.Range("d" & x).Value 'where this column contains the complete folder pathname ie: "c:\windows\thisfolder\"
NewFileName = Dir(Folder, vbNormal)
MonMessage.To = SendTo
MonMessage.Subject = Esubject
MonMessage.body = Ebody

Do While NewFileName <> &quot;&quot;
MonMessage.Attachments.Add (Folder & NewFileName)
NewFileName = Dir
Loop
MonMessage.send
Set MonOutlook = Nothing
Set MonMessage = Nothing
Next x
End Sub

HTH

Matt