Skip processing where values are blanks using Excel VBA - vba

I have an Excel sheet with email addresses, To, CC, Subject etc.
I have file paths to each attachment. These are statements. Some .PDF and some .XLSX depending on the request. Although I have the file path to each, some have multiple Columns E-L but not all rows will have a file path and not always a statement at the end of the path.
I need the VBA code to ignore blanks and missing files only attaching as found. This can be as many as 9 files or as little as one or none by row to recipient.
I cannot get it to run without error, in my Test environment, ignoring blank cells with no path or paths that do not have a file.
Sub SendMail()
Dim objOutlook As Object
Dim objMail As Object
Dim ws As Worksheet
Set objOutlook = CreateObject("Outlook.Application")
Set ws = ActiveSheet
For Each cell In ws.Range("A2:A196")
Set objMail = objOutlook.CreateItem(0)
With objMail
.To = cell.Value
.CC = cell.Offset(0, 1).Value
.Subject = cell.Offset(0, 2).Value
.Body = cell.Offset(0, 3).Value
.Attachments.Add cell.Offset(0, 4).Value
.Attachments.Add cell.Offset(0, 5).Value
.Attachments.Add cell.Offset(0, 6).Value
.Attachments.Add cell.Offset(0, 7).Value
.Attachments.Add cell.Offset(0, 8).Value
.Display
End With
Set objMail = Nothing
Next cell
Set ws = Nothing
Set objOutlook = Nothing
End Sub
This is my first VBA project.

Try it this way, and feel free to modify the code to suit your needs, of course..
Make a list in Sheets("Sheet1") with :
In column A : Names of the people
In column B : E-mail addresses
In column C:Z : Filenames like this C:\Data\Book2.xls (don't have to be Excel files)
The Macro will loop through each row in "Sheet1" and if there is a E-mail address in column B
and file name(s) in column C:Z it will create a mail with this information and send it.
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("Sheet1")
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 = "Testfile"
.Body = "Hi " & cell.Offset(0, -1).Value
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
https://www.rondebruin.nl/win/s1/outlook/amail6.htm

This will ignore your blanks cells in your range, assuming the values you want to ignore are in your Range A2 - A196.
Here, ignore really means to skip down to "Else" where your loop will start over. It is being ignored in the sense that the IF statement is telling it to do nothing when blank. The next line is "Next Cell" which will give you the desired result.
Sub SendMail()
Dim objOutlook As Object
Dim objMail As Object
Dim ws As Worksheet
Set objOutlook = CreateObject("Outlook.Application")
Set ws = ActiveSheet
For Each cell In ws.Range("A2:A196")
If cell.value <> "" Then 'If NOT blank, do this (your code)
Set objMail = objOutlook.CreateItem(0)
With objMail
.To = cell.Value
.CC = cell.Offset(0, 1).Value
.Subject = cell.Offset(0, 2).Value
.Body = cell.Offset(0, 3).Value
.Attachments.Add cell.Offset(0, 4).Value
.Attachments.Add cell.Offset(0, 5).Value
.Attachments.Add cell.Offset(0, 6).Value
.Attachments.Add cell.Offset(0, 7).Value
.Attachments.Add cell.Offset(0, 8).Value
.Display
End With
Set objMail = Nothing
Else 'If IS blank, do this (next cell)
End If
Next cell
Set ws = Nothing
Set objOutlook = Nothing
End Sub

Related

Get share link of files in specific folder of OneDrive

Can anyone give me an example of VBA (Excel) code for get share links (edit) for each file in specific folder in OneDrive?
Or a useful link?
Thanks
Tudor
I'm not sure what you are asking for, but maybe it is this...
Sub GetFolder_Data_Collection()
Range("A:L").ClearContents
Range("A1").Value = "Name"
Range("B1").Value = "Path"
Range("C1").Value = "Size (KB)"
Range("D1").Value = "DateLastModified"
Range("E1").Value = "Attributes"
Range("F1").Value = "DateCreated"
Range("G1").Value = "DateLastAccessed"
Range("H1").Value = "Drive"
Range("I1").Value = "ParentFolder"
Range("J1").Value = "ShortName"
Range("K1").Value = "ShortPath"
Range("L1").Value = "Type"
Range("A1").Select
Dim strPath As String
'strPath = "I:\Information Security\KRI Monthly Data Collection\"
strPath = GetFolder
Dim OBJ As Object, Folder As Object, File As Object
Set OBJ = CreateObject("Scripting.FileSystemObject")
Set Folder = OBJ.GetFolder(strPath)
Call ListFiles(Folder)
Dim SubFolder As Object
For Each SubFolder In Folder.SubFolders
Call ListFiles(SubFolder)
Call GetSubFolders(SubFolder)
Next SubFolder
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub ListFiles(ByRef Folder As Object)
On Error Resume Next
For Each File In Folder.Files
ActiveCell.Offset(1, 0).Select
ActiveCell = File.Name
ActiveCell.Offset(0, 1).Select
ActiveCell.Offset(0, 1) = File.Path
ActiveCell.Offset(0, 0).Hyperlinks.Add Anchor:=ActiveCell.Offset(0, 0), Address:=File.Path, TextToDisplay:=File.Path
ActiveCell.Offset(0, -1).Select
ActiveCell.Offset(0, 2) = (File.Size / 1024) 'IN KB
ActiveCell.Offset(0, 3) = File.DateLastModified
ActiveCell.Offset(0, 4) = File.Attributes
ActiveCell.Offset(0, 5) = File.DateCreated
ActiveCell.Offset(0, 6) = File.DateLastAccessed
ActiveCell.Offset(0, 7) = File.Drive
ActiveCell.Offset(0, 8) = File.ParentFolder
ActiveCell.Offset(0, 9) = File.ShortName
ActiveCell.Offset(0, 10) = File.ShortPath
ActiveCell.Offset(0, 11) = File.Type
Next File
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub GetSubFolders(ByRef SubFolder As Object)
Dim FolderItem As Object
On Error Resume Next
For Each FolderItem In SubFolder.SubFolders
Call ListFiles(FolderItem)
Call GetSubFolders(FolderItem)
Next FolderItem
End Sub
Function GetFolder() As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function
That's a completely different thing. If you want to email different files to different people, setup an Excel 'template' according to your specific needs, and run the script below.
Make a list in Sheets("Sheet1") with :
In column A : Names of the people
In column B : E-mail addresses
In column C:Z : Filenames like this C:\Data\Book2.xls (don't have to be Excel files)
The Macro will loop through each row in "Sheet1" and if there is a E-mail address in column B
and file name(s) in column C:Z it will create a mail with this information and send it.
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("Sheet1")
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 = "Testfile"
.Body = "Hi " & cell.Offset(0, -1).Value
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
https://www.rondebruin.nl/win/s1/outlook/amail6.htm
If you want to email different files to different people, see the script below.
Make a list in Sheets("Sheet1") with :
In column A : Names of the people
In column B : E-mail addresses
In column C:Z : Filenames like this C:\Data\Book2.xls (don't have to be Excel files)
The Macro will loop through each row in "Sheet1" and if there is a E-mail address in column B
and file name(s) in column C:Z it will create a mail with this information and send it.
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("Sheet1")
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 = "Testfile"
.Body = "Hi " & cell.Offset(0, -1).Value
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

Mails with attachments through vba macro

I am running a macro for sending mails to multiple recipients via Outlook with one or more attachments through vba excel. I am not well versed in macros and hence took some inputs from various sources and came upon the below final code.
However I have mentioned max. limit of 3 file attachments which is constant for all recipients but have to disable by commenting whenever I have to attach only 1 or 2 files accordingly like e.g in the below code I have disabled the 2nd and 3rd attachment columns for attaching 1 file across.
Is there any way where the macro would automatically take the inputs according to the values entered and left blank e.g If one recipient has 1 attachment and the next recipient has 2 or 3 attachments
Sub SendMail()
Dim objOutlook As Object
Dim objMail As Object
Dim ws As Worksheet
Set objOutlook = CreateObject("Outlook.Application")
Set ws = ActiveSheet
For Each cell In ws.Range("A2:A1000")
Set objMail = objOutlook.CreateItem(0)
With objMail
.To = cell.Value
.Cc = cell.Offset(0, 1).Value
.Bcc = cell.Offset(0, 2).Value
.Subject = cell.Offset(0, 3).Value
.Body = cell.Offset(0, 4).Value
.Attachments.Add cell.Offset(0, 5).Value
'.Attachments.Add cell.Offset(0, 6).Value
'.Attachments.Add cell.Offset(0, 7).Value
.Send
End With
Set objMail = Nothing
Next cell
Set ws = Nothing
Set objOutlook = Nothing
End Sub
Dim i As Long, c As Range
'....
With objMail
.To = cell.Value
.Cc = cell.Offset(0, 1).Value
.Bcc = cell.Offset(0, 2).Value
.Subject = cell.Offset(0, 3).Value
.Body = cell.Offset(0, 4).Value
For i = 5 to 6
Set c = cell.Offset(0, i)
If c.Value <> "" Then .Attachments.Add c.Value
Next i
.Send
End With
'....

Excel VBA Embed Individual Images to List of Email Contacts

I have been assigned to send out Christmas greetings that have been customized to specific customers. However, these greetings are in the 100's and doing it automatically would save me hours - and these greetings are done every year!
In Excel, the customer names are listed in column A, the individual emails in column B, and the path to the individual customized greeting file in column C.
What I have currently found is a VBA code that offers me the option to attach (but not embed) these files through their paths to the individual emails.
Might anyone explain to me and/or demonstrate how to embed the attached files that are found through column C ?
Thank you very much!
What I have now is the following:
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("Sheet1")
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 = "Merry Christmas!"
.Body = "Merry Christmas!"
For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value, olByValue, 0
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
You could do using HTML email, something like
Set o = Application.CreateItem(olMailItem)
o.BodyFormat = olFormatHTML
o.HTMLBody = "<img src='C:\Users\Pictures\a1.png'>"
o.Display

Adding email sent status to Excel

I use Excel to send monthly statements to our brokers. Is there a way to add a column to show if each of the individual email is actually sent.
Some of the rows might have an invalid email address and the only way I can tell if all of them are sent is by going through my sent folder.
Sub SendEmails()
Dim answer As Variant
answer = MsgBox("You are about to send the statements. Proceed?", vbYesNo + vbQuestion, "Alert")
Select Case answer
Case vbYes
MsgBox "Process may take a while to finish. Do not attempt to close the worksheet or Outlook.", vbInformation, "Alert"
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("Listing")
Set OutApp = CreateObject("Outlook.Application")
For Each cell In sh.Columns("D").Cells.SpecialCells(xlCellTypeConstants)
Set rng = sh.Cells(cell.Row, 1).Range("A1:B1")
If cell.Value Like "?*#?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = cell.Value
.Subject = "Statement of Account - " & cell.Offset(0, 2).Value
.Body = cell.Offset(0, 1).Value
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
Case vbNo
GoTo Quit:
End Select
Quit:
End Sub
Why not just Resolve each Recipient's email before sending
eg:
For Each olRecip In .Recipients
olRecip.Resolve
If Not olRecip.Resolve Then
olMsg.Display
End If

Send Mail with email address in 4 columns

I send email with Ron de Bruin's script where it has option for sending of email address from column B value.
I have at least 4 columns of email address from column B to E. How can I modify this to send this e-mail?
Example:
Make a list in Sheets("Sheet1") with :
In column A : Names of the people
In column B : E-mail addresses
In column C:Z : Filenames like this: C:\Data\Book2.xls (doesn't have to be Excel files)
The macro will loop through each row in Sheet1 and if there is an e-mail address in column B and file name(s) in column C:Z it will create a mail with this information and send it.
Sub Send_Files()
'Working in Excel 2000-2013
'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("Sheet1")
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 = "Testfile"
.Body = "Hi " & cell.Offset(0, -1).Value
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
MASSIVE EDIT
As per your comment, the code below is changed. Should be working under the assumption that there is a filename in Column F. The lines to remove/comment out are marked in the code below in case you don't want this requirement.
Private Sub Send_Files()
'Working in Excel 2000-2013
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'--BK201 mod: http://stackoverflow.com/questions/20776481/send-mail-with-email-address-in-4-columns--'
Dim OutApp As Object
Dim OutMail As Object
Dim Sh As Worksheet
Dim FileCell As Range
Dim Rec As Range, RecRng As Range, RecList As Range, RecMail As Range
Dim FileRng As Range
Dim RecStr As String
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set Sh = ThisWorkbook.Sheets("Sheet1")
Set RecList = Sh.Range("B:B")
Set OutApp = CreateObject("Outlook.Application")
For Each Rec In RecList
With Sh
Set RecRng = .Range("B" & Rec.Row & ":E" & Rec.Row)
Set FileRng = .Range("F" & Rec.Row)
End With
RecStr = ""
For Each RecMail In RecRng
If RecMail.Value Like "?*#?*.?*" Then
RecStr = RecStr & RecMail.Value & ";"
End If
Next RecMail
If Len(FileRng.Value) > 0 Then '--Comment out if alright to send without attachment.
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = RecStr
.Subject = "Testfile"
.Body = "Hi " & Rec.Offset(0, -1).Value
On Error Resume Next
For Each FileCell In FileRng
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
.Display '.Send
End With
Set OutMail = Nothing
Else '--Comment out if alright to send without attachment.
Exit For '--Comment out if alright to send without attachment.
End If '--Comment out if alright to send without attachment.
Next Rec
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Set-up:
Result:
Hope this helps. :)