Dec 20 2020 10:15 PM
I am using the Ron de Bruin macro to send automatic emails to various users and that is working perfectly.
As below:
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
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set sh = Sheets("book1")
Set OutApp = CreateObject("Outlook.Application")
For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
'Enter the path/file names in the C:Z column in each row
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
.to = cell.Value
.Subject = "Attachments for Account - " & cell.Offset(0, -1).Value
.BodyFormat = 1
.HTMLBody = "<HTML><body> Good day, <p> Please find attached document for your attention. </p> <p> Thank you. </p> <p> Regards. </p> </body></HTML>"
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
End Sub
My columns in Excel are as follows:
The "account name" and the "file name" (file I am linking to) is exactly the same.
Is it possible to add onto the existing macro a way in which that account name will automatically filter against a specified folder on Windows and add the links to the on the "file names" column automatically on the Excel sheet instead of manually going to change it? This will be changed every month.
Dec 21 2020 03:12 AM
SolutionMake sure that the file names in column C include the extension (e.g. Report.pdf, not Report).
See if this does what you want:
Sub Send_Files()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
' *** Change as needed, keep trailing backslash ***
Const Folder = "C:\Attachments\"
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set sh = Sheets("book1")
For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*@?*.?*" Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = cell.Value
.Subject = "Attachments for Account - " & cell.Offset(0, -1).Value
.BodyFormat = 1
.HTMLBody = "<HTML><body> Good day, <p> Please find attached document for your attention. </p> " & _
"<p> Thank you. </p> <p> Regards. </p> </body></HTML>"
Set FileCell = cell.Offset(0, 1)
If Trim(FileCell.Value) <> "" Then
If Dir(Folder & FileCell.Value) <> "" Then
.Attachments.Add Folder & FileCell.Value
End If
End If
.Send 'Or use .Display
End With
Set OutMail = Nothing
End If
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Dec 21 2020 03:12 AM
SolutionMake sure that the file names in column C include the extension (e.g. Report.pdf, not Report).
See if this does what you want:
Sub Send_Files()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
' *** Change as needed, keep trailing backslash ***
Const Folder = "C:\Attachments\"
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set sh = Sheets("book1")
For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*@?*.?*" Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = cell.Value
.Subject = "Attachments for Account - " & cell.Offset(0, -1).Value
.BodyFormat = 1
.HTMLBody = "<HTML><body> Good day, <p> Please find attached document for your attention. </p> " & _
"<p> Thank you. </p> <p> Regards. </p> </body></HTML>"
Set FileCell = cell.Offset(0, 1)
If Trim(FileCell.Value) <> "" Then
If Dir(Folder & FileCell.Value) <> "" Then
.Attachments.Add Folder & FileCell.Value
End If
End If
.Send 'Or use .Display
End With
Set OutMail = Nothing
End If
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub