Good day
The code below generates a unique email + attachment to each line in column A based on other columns.
This means if the same email exists more than once, they will receive more than one email. What I would like it to do is check whether the email exists in more than one line (already sorted) and send them one email only instead (with all the attachments). is this possible?
this is my code:
Dim objOutlook As Outlook.Application
Dim objMail As Outlook.MailItem
Dim rngTo As Range
Dim rngSubject As Range
Dim rngBody As Range
Dim rngAttach As Range
ActiveSheet.Range("A2").Select
Do Until IsEmpty(ActiveCell)
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItemFromTemplate("C:\Desktop\EBILL\template.oft")
With objMail
.To = ActiveCell.Offset(0, 4).Value
.Subject = "Invoice For: " & " " & Month & " - " & Year
.Attachments.Add ActiveCell.Offset(0, 5).Value
ActiveCell.Offset(1, 0).Select
.Display 'Instead of .Display, you can use .Send to send the email or .Save to save a copy in the drafts folder
End With
Loop
Set objOutlook = Nothing
Set objMail = Nothing
Set rngTo = Nothing
Set rngSubject = Nothing
Set rngBody = Nothing
Set rngAttach = Nothing
Found a working answer. Hope this can help someone with a similar situation
With objMail
.To = ActiveCell.Offset(0, 4).Value
.Subject = "Invoice For: " & " " & Month & " - " & Year
.Attachments.Add ActiveCell.Offset(0, 5).Value
ActiveCell.Offset(1, 0).Select
Do Until ActiveCell.Offset(0, 4).Value <> .To
.Attachments.Add ActiveCell.Offset(0, 5).Value
ActiveCell.Offset(1, 0).Select
Loop
.Display 'Instead of .Display, you can use .Send to send the email or .Save to save a copy in the drafts folder
End With
Related
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
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
'....
I am an absolute beginner and try to facilitate a few tasks in my colleagues daily work. I want to create a code that sends reminder mails with information from an excel file. The idea is that Excel should check every relevant row from row 12 on and check if there is an "x" written in a column that marks for which row I would like to send a reminder.
With the code below I can generate all the emails, but I have difficulties where and how to include the check for if ('If Cells(s, 6).Value = "x" Then') so that that Excel continues through all the rows that are filled out.
Many thanks for your help!
Sub SendReminderMail()
Dim s As Long
Dim OutLookApp As Object
Dim OutLookMailItem As Object
Dim iCounter As Integer
Dim MailDest As String
If MsgBox("Are you sure?", vbYesNo) = vbNo Then Exit Sub
Set OutLookApp = CreateObject("Outlook.application")
Set OutLookMailItem = OutLookApp.CreateItem(0)
s = 12
Do Until Trim$(Cells(s, 1).Value) = ""
Set OutLookMailItem = OutLookApp.CreateItem(0)
With OutLookMailItem
.To = Cells(s, 5).Value
.Subject = "Reminder: " & Cells(1, 7).Value
.Body = "Text, " & vbCrLf & vbCrLf & "Text'" & Cells(s, 2).Value
s = s + 1
.Display
End With
Loop
End Sub
Since you are checking every row with the Do...Loop then you need to check the if inside that loop. I've moved the increment to s outside the If so that it happens whether or not you create a mail item. Otherwise you'd only change rows if there was a mail item to send, and that means you'd be stuck looping on a row where there was no "x".
Sub SendReminderMail()
Dim s As Long
Dim OutLookApp As Object
Dim OutLookMailItem As Object
Dim iCounter As Integer
Dim MailDest As String
If MsgBox("Are you sure?", vbYesNo) = vbNo Then Exit Sub
Set OutLookApp = CreateObject("Outlook.application")
Set OutLookMailItem = OutLookApp.CreateItem(0)
s = 12
Do Until Trim$(Cells(s, 1).Value) = ""
If Cells(s,6).Value = "x" Then
Set OutLookMailItem = OutLookApp.CreateItem(0)
With OutLookMailItem
.To = Cells(s, 5).Value
.Subject = "Reminder: " & Cells(1, 7).Value
.Body = "Text, " & vbCrLf & vbCrLf & "Text'" & Cells(s, 2).Value
.Display
End With
End If
s = s + 1
Loop
End Sub
I have to order reports on accounts daily and then send an email with all of the reports but it has to be formatted a certain way. I finally made an Excel macro to order the reports but I am trying to make the macro also email the reports. Here is what I have so far.
Sub Email()
Dim OutApp As Object
Dim OutMail As Object
Dim Email As String
Dim ws As Worksheet
Set ws = Worksheets("Data")
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
K = 2
Do While ws.Cells(K, 1) <> ""
ws.Cells(K, 5) = "ACCT:" & ws.Cells(K, 1).Value
K = K + 1
Loop
Email = "Hello, <br><br>" & _
"The following reports were ordered today: <br><br>" & _
"<br> ws.Cells(2, 5) & _
'"<br> ACCT:" & ws.cells(1, 2) & _
"<br><br> Thank you." & _
"<br><br><br> <i> Please note Call if you have any questions </i>" & _
With OutMail
.to = "me#me.com"
.CC = ""
.BCC = ""
.Subject = "Statements Ordered"
.HTMLBody = Email
.Send
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
What I have it do is take the AC numbers that are in the book in column A and then match it with ACCT: so that cells E:E900 have ACCT: 12345.... but I dont know how to add that cell into the HTML body. Below it I have commented out a 2nd way I tried but also failed and that was to try and match the ACCT: & ws.Cells(1,2).
So Question: is there a way to either use an If then statement inside of the HTMLbody or is there a way to add the cell value inside the HTMLbody?
I have a list of accounts and relevant information that I have to split up and send specific accounts to certain people. This has to be done about 50 times. I already have a program setup that will filter, copy the data to a new file, and save. Is there a way to set it up to then email this file based on a list of contacts?
Each account is covered by a region, so I have a list which has the region and the contact's email. In the macro that splits by the regions, it has an array of these regions so is some kind of lookup possible from the list of contacts?
Code:
Sub SplitFile()
Dim rTemp As Range
Dim regions() As String
Set rTemp = ThisWorkbook.Sheets("Combined").Range("AH2:AH1455")
regions = UniqueItems(rTemp, False)
For N = 1 To UBound(regions)
Set wb = Workbooks.Add
ThisWorkbook.Sheets("DVal").Copy _
after:=ActiveWorkbook.Sheets("Sheet1")
With ThisWorkbook.Sheets("Combined")
.AutoFilterMode = False
' .AutoFilter
.Range("A1:BP1455").AutoFilter Field:=34, Criteria1:=regions(N)
Application.DisplayAlerts = False
.Range("A1:BP1455").Copy wb.Sheets("Sheet1").Range("A1")
Application.DisplayAlerts = True
For c = 1 To 68
wb.Sheets("Sheet1").Range("A1:BP2694").Columns(c).ColumnWidth = .Columns(c).ColumnWidth
Next c
End With
With wb
.Sheets("Sheet1").Activate
.SaveAs Filename:="H:\" & regions(N) & " 14-12-11"
.Close True
End With
Set wb = Nothing
Next N
End Sub
I am assuming you want to do it programmaticaly using VB, you can do something like
Dim msg As System.Web.Mail.MailMessage = New System.Web.Mail.MailMessage()
msg.From = "noone#nobody.com"
msg.To = "someone#somewhere.com"
msg.Subject = "Email with Attachment Demo"
msg.Body = "This is the main body of the email"
Dim attch As MailAttachment = New MailAttachment("C:\attachment.xls")
msg.Attachments.Add(attch)
SmtpMail.Send(msg)
If you're having trouble with the above, my mail macro is different; this is used with excel 2007:
Sub Mail()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "To Whom It May Concern:" & vbNewLine & vbNewLine & _
"This is a test!" & vbNewLine & _
"This is line 2" & vbNewLine & _
"This is line 3" & vbNewLine & _
"This is line 4"
On Error Resume Next
With OutMail
.to = "anyone#anywhere.com"
.cc = ""
.BCC = ""
.Subject = "This is only a test"
.Body = strbody
'You can add an attachment like this
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Jon
I am assuming the following.
1) Regions are in Col AH
2) Contacts are in Col AI
3) UniqueItems() in your code removes duplicates?
Please try the below code. I have commented the code so please go through them and make relevant changes. Especially to the part where you save the File. I have used Late Binding with Outlook.
NOTE: I always test my code before posting but in the current scenario I cannot so do let me know if you find any errors.
Option Explicit
Sub SplitFile()
'~~> Excel variables
Dim wb As Workbook, wbtemp As Workbook
Dim rTemp As Range, rng As Range
Dim regions() As String, FileExt As String, flName As String
Dim N As Long, FileFrmt As Long
'~~> OutLook Variables
Dim OutApp As Object, OutMail As Object
Dim strbody As String, strTo As String
On Error GoTo Whoa
Application.ScreenUpdating = False
Set wb = ActiveWorkbook
'~~> Just Regions
Set rTemp = wb.Sheets("Combined").Range("AH2:AH1455")
'~~> Regions and Email address. We wil require this later
'~~> Tofind email addresses
Set rng = wb.Sheets("Combined").Range("AH2:AI1455")
regions = UniqueItems(rTemp, False)
'~~> Create an instance of outlook
Set OutApp = CreateObject("Outlook.Application")
For N = 1 To UBound(regions)
Set wb1 = Workbooks.Add
wb.Sheets("DVal").Copy after:=wb1.Sheets(1)
With wb.Sheets("Combined")
.AutoFilterMode = False
With .Range("A1:BP1455")
.AutoFilter Field:=34, Criteria1:=regions(N)
'~~> I think you want to copy the filtered data???
.Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy _
wb1.Sheets("Sheet1").Range("A1")
For c = 1 To 68
wb1.Sheets("Sheet1").Range("A1:BP2694").Columns(c).ColumnWidth = _
wb.Columns(c).ColumnWidth
Next c
End With
End With
'~~> Set the relevant Fileformat for Save As
' 51 = xlOpenXMLWorkbook (without macro's in 2007-2010, xlsx)
' 52 = xlOpenXMLWorkbookMacroEnabled (with or without macro's in 2007-2010, xlsm)
' 50 = xlExcel12 (Excel Binary Workbook in 2007-2010 with or without macro's, xlsb)
' 56 = xlExcel8 (97-2003 format in Excel 2007-2010, xls)
FileFrmt = 52
Select Case FileFrmt
Case 50: FileExt = ".xlsb"
Case 51: FileExt = ".xlsx"
Case 52: FileExt = ".xlsm"
Case 56: FileExt = ".xls"
End Select
'~~> Contruct the file name.
flName = "H:\" & regions(N) & " 14-12-11" & FileExt
'~~> Do the save as
wb1.SaveAs Filename:=flName, FileFormat:=FileFrmt
wb1.Close SaveChanges:=False
'~~> Find the email address
strTo = Application.WorksheetFunction.VLookup(regions(N), rng, 2, 0)
'~~> Create new email item
Set OutMail = OutApp.CreateItem(0)
'~~> Create the body of the email here. Change as applicable
strbody = "Dear Mr xyz..."
With OutMail
.To = strTo
.Subject = regions(N) & " 14-12-11" '<~~ Change subject here
.Body = strbody
.Attachments.Add flName
'~~> Uncomment the below if you just want to display the email
'~~> and comment .Send
'.Display
.Send
End With
Next N
LetContinue:
Application.ScreenUpdating = True
'~~> CleanUp
On Error Resume Next
Set wb = Nothing
Set wb1 = Nothing
Set OutMail = Nothing
OutApp.Quit
Set OutApp = Nothing
On Error GoTo 0
Whoa:
MsgBox Err.Description
Resume LetContinue
End Sub