VBA grab email list from table in another sheet and use as send To

[Melimob]

Hi there

I have the below code which I know is incorrect for the To. but I don't know how to fix? would appreciate any help. I have the list on another sheet. It's in a table if that helps: Table16

[CODE]
Sub emailsavePDF_weekly()


Dim objOutlook As Object
Dim objMail As Object
Dim signature As String
Dim oWB As Workbook
Set oWB = ActiveWorkbook
Dim PDF_File As String



s = Range("b1").Value

'
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
s, Quality:=xlQualityStandard, IncludeDocProperties _
:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False


PDF_File = Range("b1").Value


Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)

With objMail
.display
End With
signature = objMail.body
With objMail
[COLOR=#ff0000] .To = Sheets("DataLists_Lkup") & Range("F2:F20").Value[/COLOR]
.Cc = "test@test.co.uk"
.Subject = "Weekly League Tables for Banked vs Written " & Range("e2").Value
' .body = "Hi " & Range("B2").Value & "," _
& vbNewLine & vbNewLine & _
"Please find attached your monthly commission statement for " & Range("I3").Value _
& vbNewLine & vbNewLine _
& "Any questions please do not hesitate to ask." _
& vbNewLine & vbNewLine _
& "Kind Regards, Lindsay" _
& vbNewLine _
& signature
.body = "Hi " & Range("B2").Value & "," _
& vbNewLine & vbNewLine & _
"Please find attached this weeks' league tables." _
& vbNewLine & vbNewLine _
& "Any questions please do not hesitate to ask." _
& vbNewLine & vbNewLine _
& "Kind Regards," _
& vbNewLine _
& "Lindsay" _
& vbNewLine _
& signature
.Attachments.Add PDF_File
.Save
.display
End With
'_




Set objOutlook = Nothing
Set objMail = Nothing
End Sub


'HTMLbody = "****** style=font-size:11pt;font-family:Calibri>




[/CODE]

Many thanks
Melissa

 

[Logit]

.

Option Explicit


Sub SendEmailfromOutlook()




    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
    Dim Path As String
    Dim i As Integer
    
    Path = Application.ActiveWorkbook.Path
    Set OutApp = CreateObject("Outlook.Application")




    For Each cell In Range("C2:C10")  '<-- edit column for email addresses location
    If cell.Value <> "" Then
        Set OutMail = OutApp.CreateItem(0)
        
            With OutMail
            
                .To = cell.Value
                
                .Subject = Cells(cell.Row, "D").Value   '<-- edit for Subject each email address
                
                '<-- edit next line range for Name each email address'
                .Body = "Dear " & Cells(cell.Row, "B").Value & "," _
                & vbNewLine & vbNewLine & _
                "Please find attached a list of overdue invoices. Thank you!"
                
                .Attachments.Add (Path & "\" & Cells(cell.Row, "E").Value)  '<-- edit path to the pdf file
                                
                '.Send      'uncomment if you want to auto send email without first reviewing
                .Display    'comment out if you uncomment .Send
                                
            End With
        End If
    Next cell
    
End Sub

 

[Melimob]

thanks for this however my cell range is on a different sheet? I have worked out an alternative to reference the list on this sheet and read from that however I am having issues with this formula now: =CONCATENATE(TRANSPOSE(DataLists_Lkup!F2:F12)&";") entered with CTRL + Shift +Enter as it's only picking up the first email address?

I will raise a new post on it though. thank you for your help. it is appreciated.

 

[daverunt]

Hi,

You can always concatenate the range of addresses.

Set rng = Worksheets("DataLists_Lkup").Range("F2:F12")
      
For Each cell In rng

SendTo = SendTo & cell.Value & "; "

Next
MsgBox (SendTo)

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

.To = SendTo

 

[daverunt]

Check it resembles an email address.

For Each cell In rng
If cell.Value Like "?*@?*.?*" Then
SendTo = SendTo & cell.Value & "; "
End If
Next
MsgBox (SendTo)

 

[Melimob]

Check it resembles an email address.

For Each cell In rng
If cell.Value Like "?*@?*.?*" Then
SendTo = SendTo & cell.Value & "; "
End If
Next
MsgBox (SendTo)

thanks so much. I got my concatanate and transpose to finally work. you have to do F9 within the concatanate and then remove the array symbols and enter!

thank you!