Email multiple people with different attachments (2 attachments per email) [Archive]

YOYO

10-10-2018, 11:40 AM

I have a list of 13 emails which I would need to send individual emails to as they require 2 different attachments for them.

Here is what I have to send one attachment and works fine:
Column A - Greetings, (Good Morning or Good Afternoon, depends on the time I send out)
Column B - Recipient's email address
Column C - Attachment (file path)
Column D - Attachment name (file name)
Column E - Email Subject

Note: the attachments need send to example3 are the only excel file, the rest are all pdfs.

ref#
Email
File Path
File Name
Recipient's Subject

Good Afternoon
example1@gmail.com
C:\Users\Desktop\Example1.pdf
Example1_2018-08.pdf
Example1 as of August 2018

Good Afternoon
example2@gmail.com
C:\Users\Desktop\Example2.pdf
Example2_2018-08.pdf
Example2 as of August 2018

Good Afternoon
example3@gmail.com
C:\Users\Desktop\Example3.xlsx
Example2_2018-08.xlsx
Example3 as of August 2018

Now, what I need the VBA to do is to send Recipient example1 two attachments: the file name end with "2018-08", will change to "2018-09" next time, but the second attachment will stay the same.

Example1_2018-08.pdf and Example1.pdf

Example2_2018-08.pdf and Example2.pdf

Example3_2018-08.xlsx and Example3.xlsx
......

Here is my current code:

Sub Get_Files()
Dim SourceDir, R
Dim fso, Fldr, Files, File
Dim Sht

Set fso = CreateObject("Scripting.FileSystemObject")
Sht = "Summary"
Sheets(Sht).Range("A2:D100000").ClearContents
SourceDir = "C:\Users\Desktop"
R = 1
If (fso.folderexists(SourceDir)) Then
Set Fldr = fso.getfolder(SourceDir)
Set Files = Fldr.Files
For Each File In Files
If (Right(File.Name, 3) = "pdf") Then
R = R + 1
Sheets(Sht).Cells(R, "D").Value = File.Name
End If

If (Right(File.Name, 4) = "xlsx") Then
R = R + 1
Sheets(Sht).Cells(R, "D").Value = File.Name
End If
Next
End If

Call DeleteRows

Worksheets("Summary").Activate
Range("D1").FormulaR1C1 = "C:\Users\Desktop\"
Range("A2").FormulaR1C1 = "=IF(MOD(NOW(),1)<0.5,""Good Morning "",IF(MOD(NOW(),1)<0.75,""Good Afternoon "",""Good Evening ""))"
Range("B2").FormulaR1C1 = "=VLOOKUP(LEFT(RC[2],FIND(""_"",RC[2],FIND(""_"",RC[2])+1)-1),Emails!C[-1]:C,2,FALSE)"
Range("C2").FormulaR1C1 = "=R1C4&RC[1]"
Range("F2").FormulaR1C1 = "='Rename Files'!R2C4"
Range("G2").FormulaR1C1 = "=TEXT(DATE(2000,'Rename Files'!R2C5,1),""mmmm"")"
Range("A2").AutoFill Destination:=Range("A2:A" & Cells(Rows.Count, "D").End(xlUp).Row)
Range("C2").AutoFill Destination:=Range("C2:C" & Cells(Rows.Count, "A").End(xlUp).Row)
Range("B2").AutoFill Destination:=Range("B2:B" & Cells(Rows.Count, "A").End(xlUp).Row)
Range("F2").AutoFill Destination:=Range("F2:F" & Cells(Rows.Count, "A").End(xlUp).Row)
Range("G2").AutoFill Destination:=Range("G2:G" & Cells(Rows.Count, "A").End(xlUp).Row)

Columns("A:C").Select
Range("A2").Activate
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False

Columns("F:G").Select
Range("F2").Activate
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False

Range("D1") = "File Name"
Range("A1").Select

Call RecipientsName

Columns("F:G").Select
Selection.Delete

End Sub

Sub DeleteRows()
Dim c As Range
Dim SrchRng

Worksheets("Summary").Activate

Set SrchRng = ActiveSheet.Range("D1", ActiveSheet.Range("D65536").End(xlUp))
Do
Set c = SrchRng.Find("Report", LookIn:=xlValues)
If Not c Is Nothing Then c.EntireRow.Delete

Loop While Not c Is Nothing

Set SrchRng = ActiveSheet.Range("D1", ActiveSheet.Range("D65536").End(xlUp))
Do
Set c = SrchRng.Find("Example", LookIn:=xlValues)
If Not c Is Nothing Then c.EntireRow.Delete

Loop While Not c Is Nothing

End Sub

Sub RecipientsName()

Range("E2").Select
ActiveCell.FormulaR1C1 = _
"=LEFT(RC[-1],FIND(""_"",RC[-1],FIND(""_"",RC[-1])+1)-1)&"" as of ""&RC[2] &"" "" &RC[1]"

Range("E2").Copy
Range("E2").AutoFill Destination:=Range("E2:E" & Cells(Rows.Count, "D").End(xlUp).Row)
Range("E2:E65000").Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Range("E1") = "Recipient's Subject"
Range("E1").Font.Bold = True

End Sub

Sub Send_Files()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range
Dim answer As Integer

answer = MsgBox("Are you sure you want to send files?", vbYesNo + vbQuestion, "Send Files")

If answer = vbYes Then

With Application
.EnableEvents = False
.ScreenUpdating = False
End With

Set sh = Sheets("Summary")

Set OutApp = CreateObject("Outlook.Application")

For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)

Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")

If cell.Value Like "?*@?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)

With OutMail
.Display
End With
Signature = OutMail.HTMLBody

With OutMail
.to = cell.Value
.cc = "xxxx@gmail.com"
.Subject = cell.Offset(0, 3).Value
.HTMLBody = "" & cell.Offset(0, -1).Value & "," _
& " Please find attached your monthly schedule for xxxxxxxx." _
& " Thank you. " _
& " Sincerely," & Signature

For Each FileCell In rng.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

Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With

Else
'do nothing
End If

End Sub

Example1_2018-08.pdf