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 = "<font face = Times New Roman><p style=font-size:14.5px>" & cell.Offset(0, -1).Value & "," _
& "<br><br> Please find attached your monthly schedule for xxxxxxxx." _
& "<br><br> Thank you. " _
& "<br><br> 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