How to send each sheet to different mail adress

[Celeste1234]

Hi,

I have made a code to send each sheet to a mail adress. However I don't succeed in sending the sheets based on a adress list.

In Sheet "Adressenlijst" I have the name of the other sheets in Column A, the name of the adressee in column B, and in column C the email adresses.

So I want for sheet "Amsterdam Oost", to lookup the name in Sheet "Adressenlijst" and then pick column C.

The code works when I just enter an email adress at To, but now it cannot find the email adress. I tried using Vlookup and if .. then

Can anybody help? Below the code.

Thanks!



Sub Adam()

Dim iConfirmation As VbMsgBoxResult
iConfirmation = MsgBox("Emails verzenden?", vbYesNo + vbQuestion, "Confirmation")
If iConfirmation = vbNo Then Exit Sub

For Each sh In ThisWorkbook.Sheets
Dim Wb As Workbook
Dim FileName As String
Dim OutlookApp As Object
Dim OutlookMail As Object
Dim adress As Object

On Error Resume Next
Set Wb = Application.ActiveWorkbook
If sh.Name = "Amsterdam West" Or sh.Name = "Amsterdam Oost" Then
FileName = sh.FullName
xIndex = VBA.InStrRev(FileName, ".")
If xIndex > 1 Then FileName = VBA.Left(FileName, xIndex - 1)
FileName = sh.Name + ".pdf"
sh.ExportAsFixedFormat Type:=xlTypePDF, FileName:=FileName

Set myrange = Sheets("Adressenlijst").Range("A:C")
Adresses = "Vlookup(sh.Name, myrange, 3, 0)"

Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)
With OutlookMail
.To = Adresses
.CC = ""
.BCC = ""
.Subject = "Text"
.Body = "Text"
.Attachments.Add FileName
.Send
End With
Kill FileName
Set OutlookMail = Nothing
Set OutlookApp = Nothing



End If
Next sh

End Sub



OR


For Each cell In Sheets("Adressenlijst").Columns("A").Cells.SpecialCells(xlCellTypeConstants)

If cell.Value = sh.Name Then



Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)
With OutlookMail
.To = cell.Value.Offset(0, 2).Select
.CC = ""
.BCC = ""
.Subject = "Text"
.Body = "text"
.Send
End With
Kill FileName
Set OutlookMail = Nothing
Set OutlookApp = Nothing

End If
Next cell

[ByteMarks]

Does this work for you?

Please Login or Register  to view this content.

[Celeste1234]

Yes! Thank you!