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
Bookmarks