Sub SendEmail()
Dim OutlookApp As Object
Dim MItem As Object
Dim cell As Range
Dim email_ As String
Dim cc_ As String
Dim subject_ As String
Dim body_ As String
Dim attach_ As String
Dim StrBody As String
'Create Outlook object
Set OutlookApp = CreateObject("Outlook.Application")
'Loop through the rows
For Each cell In Sheets("publico").Range("H2:H2000").Cells.SpecialCells(xlCellTypeConstants)
If cell.Row <> 1 Then
If cell.Value <> "" Then ' to check email address cell is empty or not
email_ = cell.Value ' email address mention in the F column
Else
email_ = cell.Offset(0, 1).Value 'alternative email address
End If
subject_ = Sheets("CAPA").Range("D1").Value 'as of now i mentioned column B as subject, change the value accordingly
' body_ = Sheets("CAPA").Range("D2").Value 'please change the offset value based on the body content cell
StrBody = Sheets("CAPA").Range("D2").Value & "<br><br>" & _
Sheets("CAPA").Range("D3").Value & "<br><br>" & _
Sheets("CAPA").Range("F7").Value & "<br><br><br>"
**Sheets("publico").Range**
' cc_ = cell.Offset(0, 3).Value ' remove comments if you are going to use the cc and also change the offset value according to cc mail address cell value.
' attach_ = cell.Offset(0, 4).Value ' remove comments "'" if you going attache any file and change the offset value based on the attachment value position.
'Create Mail Item and send it
Set MItem = OutlookApp.CreateItem(0)
With MItem
.To = email_
' .CC = cc_
.Subject = subject_
.HTMLBody = StrBody
'.Attachments.Add attach_
'.Display
End With
MItem.Send
Sheets("publico").Range("J2").Value = "enviado"
End If
Next
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
So, for branch 100, manager 15, I will send line 1 and 2 of the sheet, to the manager mail only.
In the case of no manager assigned, the email will be directed to the head (email2).
After sending an e-mail, the F column must generate a log "OK".
EDIT:
I edited the code provided and the e-mail is going to the proper recipients.
Please try the below code.
Sub SendEmail()
Dim OutlookApp As Object
Dim MItem As Object
Dim cell As Range
Dim email_ As String
Dim cc_ As String
Dim subject_ As String
Dim body_ As String
Dim attach_ As String
'Create Outlook object
Set OutlookApp = CreateObject("Outlook.Application")
'Loop through the rows
For Each cell In Columns("f").Cells.SpecialCells(xlCellTypeConstants)
If cell.Row <> 1 Then
If cell.Value <> "" Then ' to check email address cell is empty or not
email_ = cell.Value 'email address mention in the F column
Else
email_ = cell.Offset(0, 1).Value 'alternative email address
End If
subject_ = cell.Offset(0, -4).Value 'as of now i mentioned column B as subject, change the value accordingly
body_ = cell.Offset(0, 2).Value 'please change the offset value based on the body content cell
' cc_ = cell.Offset(0, 3).Value ' remove comments if you are going to use the cc and also change the offset value according to cc mail address cell value.
' attach_ = cell.Offset(0, 4).Value ' remove comments "'" if you going attache any file and change the offset value based on the attachment value position.
'Create Mail Item and send it
Set MItem = OutlookApp.CreateItem(0)
With MItem
.To = email_
' .CC = cc_
.Subject = subject_
.Body = body_
'.Attachments.Add attach_
'.Display
End With
MItem.Send
cell.Value = "ok"
End If
Next
End Sub
Thanks,
Arun
Related
I have an Excel sheet with data of users as shown below in table. Here I need to send the email to user their specific details containing in column A,B,C.
Using this code, I can only send the multiple row data in multiple email, but I need to send the multiple row data in single mail to respective user.
Sub BulkMail()
Application.ScreenUpdating = False ThisWorkbook.Activate Dim outMail As Outlook.MailItem
'Creating variable to hold values of different items of mail
Dim sendTo, subj, msg, Name, Company, Time As String
Dim lstRow As Long
'My data is on sheet "Exceltip.com" you can have any sheet name.
ThisWorkbook.Sheets("Sheet2").Activate
'Getting last row of containing email id in column 1.
lstRow = Cells(Rows.Count, 1).End(xlUp).Row
'Variable to hold all email ids
Dim rng As Range
Set rng = Range("A2:A" & lstRow)
'initializing outlook object to access its features
Set outApp = New Outlook.Application
On Error GoTo cleanup 'to handle any error during creation of object.
'Loop to iterate through each row, hold data in of email in variables and send
'mail to each email id.
For Each cell In rng
sendTo = Range(cell.Address).Offset(0, 0).Value2
subj = Range(cell.Address).Offset(0, 1).Value2
msg = Range(cell.Address).Offset(0, 2).Value2
Name = Range(cell.Address).Offset(0, 3).Value2
Company = Range(cell.Address).Offset(0, 4).Value2
Time = Range(cell.Address).Offset(0, 5).Value2
On Error Resume Next 'to hand any error during creation of below object
Set outMail = outApp.CreateItem(0)
'Writing and sending mail in new mail
With outMail
.To = sendTo
.Subject = subj
strbody = msg & vbNewLine & Name & " " & Company & " " & Time
.Body = strbody
.Send 'this send mail without any notification. If you want see mail
'before send, use .Display method.
End With
On Error GoTo 0 'To clean any error captured earlier
Set outMail = Nothing 'nullifying outmail object for next mail
Next cell 'loop ends
cleanup: 'freeing all objects created
Set outApp = Nothing
Application.ScreenUpdating = True
Application.ScreenUpdating = True
End Sub
I have added two columns. In column F there are the users' name (without duplicate.I have added the last user. He doesn't have messages). In column G there are how many message there are for the user in column F.
Here an example
I have got a problem with foreach cell... and then I used the for loop (classic).
In this example I used another for. The first for check the user's name and with the second for check how many messages there are for the user. I have put one or more messages in the strbody variable. When the second for is finished, I insert the number of messages for the user (COLUMN G) and then send the email.
My Code:
Sub bulkMail()
Const COLUMN_F As Byte = 6
Const COLUMN_G As Byte = 7
Application.ScreenUpdating = False
ThisWorkbook.Activate
Dim outMail As Outlook.MailItem
'Creating variable to hold values of different items of mail
Dim sendTo, subj, msg, Name, Company, Time As String
Dim lstRow As Long
'add variable
Dim numberUsers, i,j, numberMsg As Integer
'My data is on sheet "Exceltip.com" you can have any sheet name.
ThisWorkbook.Sheets("Sheet2").Activate
'Getting last row of containing email id in column 1.
lstRow = Cells(Rows.Count, 1).End(xlUp).Row
'count number users in Column F -> 6. Here there are the users without duplicate name.
numberUsers = Cells(Rows.Count, COLUMN_F).End(xlUp).Row
'Variable to hold all email ids
'i didn't use range because i had problems with foreach (i don't know why)
'Dim rng As Range
'Set rng = Range("A2:A" & lstRow)
'initializing outlook object to access its features
Set outApp = New Outlook.Application
On Error GoTo cleanup 'to handle any error during creation of object.
'Loop to iterate through each row, hold data in of email in variables and send
'mail to each email id.
For i = 2 To numberUsers
numberMsg = 0
strbody = ""
'For Each cell In rng
For j = 2 To lstRow
'Name = Range(cell.Address).Offset(0, 3).Value2
Name = Cells(j, 1) ' I get the name column A
If (Cells(i, COLUMN_F) = Name) Then
numberMsg = numberMsg + 1 ' count the number of messages
sendTo = Cells(j, 1) 'Range(cell.Address).Offset(0, 0).Value2 - COLUMN A
subj = Cells(j, 5) 'Range(cell.Address).Offset(0, 1).Value2 - COLUMN E
msg = Cells(j, 4) 'Range(cell.Address).Offset(0, 2).Value2 - COLUMN D
'Name = cells(j,1)Range(cell.Address).Offset(0, 3).Value2
Company = Cells(j, 2) 'Range(cell.Address).Offset(0, 4).Value2 - COLUMN B
Time = Cells(j, 3) 'Range(cell.Address).Offset(0, 5).Value2 - COLUMN C
strbody = strbody & msg & vbNewLine & Name & " " & Company & " " & Time & vbNewLine
'Debug.Print (strbody)
End If
Next j 'loop ends
Cells(i, COLUMN_G) = numberMsg ' get in COLUMN G the number of message for the user in COLUMN F
On Error Resume Next 'to hand any error during creation of below object
'check if there is almost a message for a user
If (numberMsg <> 0) Then
Set outMail = outApp.CreateItem(0)
'Writing and sending mail in new mail
With outMail
.To = sendTo
.Subject = subj
'strbody = msg & vbNewLine & Name & " " & Company & " " & Time
.Body = strbody
.Send 'this send mail without any notification. If you want see mail
'before send, use .Display method.
End With
On Error GoTo 0 'To clean any error captured earlier
Set outMail = Nothing 'nullifying outmail object for next mail
End If
'Next cell 'loop ends
Next i
cleanup: 'freeing all objects created
Set outApp = Nothing
Application.ScreenUpdating = True
Application.ScreenUpdating = True
End Sub
before trying my code check if my cells match yours.
So I'm really new to VBA (and by new I mean a couple of days in). I'm looking to make a loop that will incrementally add lines to an email body if a certain condition is met. I apologise in advance if it is horrible to read but it does seem to work so far! If anyone can tell me how I can add something to the loop so that it adds a new line to the email body every time the condition is met, I would appreciate it.
Here's what I have so far:
Sub SendEmailReminder()
Dim x As Integer
Dim Removal As String
Dim RemovalTitle As String
Removal = Removal
RemovalTitle = RemovalTitle
' Set numrows = number of rows of data.
numrows = Range("C2").End(xlDown).row - 1
' Select cell 2.
Range("C2").Select
' Establish "For" loop to loop "numrows" number of times.
For x = 1 To numrows
If ActiveCell = Date - 30 Then
Removal = ActiveCell.Offset(0, -2)
RemovalTitle = ActiveCell.Offset(0, -1)
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = Removal & " - " & RemovalTitle & " needs to be removed from New Releases"
On Error Resume Next
With OutMail
.To = ""
.CC = ""
.BCC = ""
.Subject = ""
.Body = strbody
.Display 'or use .Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End If
' Selects cell down 1 row from active cell.
ActiveCell.Offset(1, 0).Select
Next
End Sub
You can do this:
Sub SendEmailReminder()
Dim x As Integer
Dim c As Range
Dim OutApp As Object
Dim strbody As String
Set c = Range("C2")
'loop while cell is not empty
Do While Len(c.Value) > 0
If c.Value = Date - 30 Then
'build the message
strbody = strbody & vbCrLf & c.Offset(0, -2) & " - " & _
c.Offset(0, -1) & " needs to be removed from New Releases"
End If
Set c = c.Offset(1, 0) 'next cell
Loop
Set OutApp = CreateObject("Outlook.Application")
On Error Resume Next
With OutApp.CreateItem(0)
.To = ""
.CC = ""
.BCC = ""
.Subject = ""
.Body = strbody
.Display 'or use .Send
End With
On Error GoTo 0
Set OutApp = Nothing
End Sub
If someone could help me from going insane, my mother would appreciate it.
I have a long list of email addresses (many repeats) with associated Audit Locations. Basically I need to create one email for each email address and populate said email body with a list of all the associated Audit Locations.
e.g.
Column One (Email Address) | Column 2 (Audit Location)
Yoda1#lightside.org | Coruscant
Yoda1#lightside.org | Death Star
Yoda1#lightside.org | Tatooine
Vader#Darkside.org | Death Star
Vader#Darkside.org | Coruscant
Jarjar#terrible.org | Yavin
So far I have created a CommandButton Controlled vba that takes Column One and makes it unique in a new worksheet.
Then I have another sub that creates an email for each unique email address. But I am stuck on the "If...Then" statement. Essentially, I want to add the information in Column 2 (Audit Location) if the Recipient of the email is the email address in Column One and then continue to append to the email body until the email address no longer equals the recipient email address. Any guidance would be huge.
Private Sub CommandButton1_Click()
Call MakeUnique
Call EmailOut
End Sub
Sub MakeUnique()
Dim vaData As Variant
Dim colUnique As Collection
Dim aOutput() As Variant
Dim i As Long
'Put the data in an array
vaData = Sheet1.Range("A:A").Value
'Create a new collection
Set colUnique = New Collection
'Loop through the data
For i = LBound(vaData, 1) To UBound(vaData, 1)
'Collections can't have duplicate keys, so try to
'add each item to the collection ignoring errors.
'Only unique items will be added
On Error Resume Next
colUnique.Add vaData(i, 1), CStr(vaData(i, 1))
On Error GoTo 0
Next i
'size an array to write out to the sheet
ReDim aOutput(1 To colUnique.Count, 1 To 1)
'Loop through the collection and fill the output array
For i = 1 To colUnique.Count
aOutput(i, 1) = colUnique.Item(i)
Next i
'Write the unique values to column B
Sheets.Add.Name = "Unique"
ActiveSheet.Range("A1").Resize(UBound(aOutput, 1), UBound(aOutput, 2)).Value = aOutput
End Sub
Sub EmailOut()
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
On Error Resume Next
Dim cell As Range
For Each cell In Worksheets("Unique").Columns("a").Cells.SpecialCells(xlCellTypeConstants)
recip = cell.Value
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
For Each org In Columns("b").Cells.SpecialCells(xlCellTypeConstants)
If org.Value Like recip Then
xMailBody = "Body content" & vbNewLine & vbNewLine & _
"This is line 1" & " " & cell.Offset(0, 3).Value & vbNewLine & _
[B5] & vbNewLine & _
"This is line 2"
End If
Next org
On Error Resume Next
With xOutMail
.To = recip
.CC = ""
.BCC = ""
.Subject = cell.Offset(0, 2).Value & " " & cell.Offset(0, 3).Value & " " & "Remittance Advice"
.Body = xMailBody
.Display 'or use .Send
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
Next
End Sub
Based on your example I quickly wrote the following:
Option Explicit
Public Sub SendEmails()
Dim dictEmailData As Object
Dim CurrentWorkBook As Workbook
Dim WrkSht As Worksheet
Dim rngToLookUp As Range
Dim lngLastRow As Long, i As Long
Dim arryEmailData As Variant
Dim objOutlookApp As Object, objOutlookEmail As Object
Dim varKey As Variant
Application.ScreenUpdating = False
Set CurrentWorkBook = Workbooks("SomeWBName")
Set WrkSht = CurrentWorkBook.Worksheets("SomeWSName")
lngLastRow = WrkSht.Cells(WrkSht.Rows.Count, "A").End(xlUp).Row 'Find last row with data
Set rngToLookUp = WrkSht.Range("A2:B" & lngLastRow) 'set range for last row of data
arryEmailData = rngToLookUp.Value2 'Get the email data from the sheet into an array
Set dictEmailData = CreateObject("Scripting.Dictionary") 'set the dicitonary object
On Error GoTo CleanFail
For i = LBound(arryEmailData, 1) To UBound(arryEmailData, 1)
varKey = UCase(Trim(arryEmailData(i, 1)))
If Not dictEmailData.Exists(varKey) Then
dictEmailData(varKey) = vbNewLine & vbNewLine & Trim(arryEmailData(i, 2))
Else
dictEmailData(varKey) = dictEmailData(varKey) & vbNewLine & Trim(arryEmailData(i, 2))
End If
varKey = Empty
Next i
'for each unique key in the dicitonary
'get the corresponding item
'created in the loop above
Set objOutlookApp = CreateObject("Outlook.Application") 'set the outlook object
Dim Msg As String, MailBody As String
For Each varKey In dictEmailData.Keys
Msg = dictEmailData.Item(varKey)
Set objOutlookEmail = objOutlookApp.CreateItem(0)
MailBody = "Dear Colleague," & Msg
With objOutlookEmail
.To = varKey
.Subject = "Remittance Advice"
.Body = MailBody
.Send
End With
Set objOutlookEmail = Nothing
Msg = Empty: MailBody = Empty
Next
MsgBox "All Emails have been sent", vbInformation
CleanExit:
Set objOutlookApp = Nothing
Application.ScreenUpdating = True
Exit Sub
CleanFail:
Resume CleanExit
End Sub
Add the first occurrence of a varKey = email address to the dictionary dictEmailData along with its corresponding item dictEmailData(varKey) = Email body. On the next occurrence of the email address, append to the Email body. Once the dictionary is built, loop through it and send the emails
Printing to the immediate window yields:
I need to download the all the emails in a particular to excel. I found a code which works pretty close, but the mail content are not pasting in a single cell.
And I would also like to have only particular details of the body. Can some one help me in modifying the below code for..
*updated:
I would need only part of mail content (as marked below) to be downloaded to excel.
Could you please help me with this.
Excel VBA Code:
Sub GetMail()
Dim olApp As Object
Dim olFolder As Object
Dim olMailItem As Object
Dim strTo As String
Dim strFrom As String
Dim dateSent As Variant
Dim dateReceived As Variant
Dim strSubject As String
Dim spBody As Variant
Dim loopControl As Variant
Dim mailCount As Long
Dim totalItems As Long
'-------------------------------------------------------------
'//Turn off screen updating
Application.ScreenUpdating = False
'//Setup headers for information
Range("A1:F1").Value = Array("To", "From", "Subject", "Body", "Sent (from Sender)", "Received (by Recipient)")
'//Format columns E and F to
Columns("E:F").EntireColumn.NumberFormat = "DD/MM/YYYY HH:MM:SS"
'//Create instance of Outlook
Set olApp = CreateObject("Outlook.Application")
'//Select folder to extract mail from
Set olFolder = olApp.GetNamespace("MAPI").PickFolder
'//Get count of mail items
totalItems = olFolder.Items.Count
mailCount = 0
'//Loop through mail items in folder
For Each loopControl In olFolder.Items
'//If loopControl is a mail item then continue
If TypeName(loopControl) = "MailItem" Then
'//Increase mailCount
mailCount = mailCount + 1
'//Inform user of item count in status bar
Application.StatusBar = "Reading email no. " & mailCount & " of " & totalItems
'//Get mail item
Set olMailItem = loopControl
'//Get Details
With olMailItem
strTo = .To
'//If strTo begins with "=" then place an apostrophe in front to denote text format
If Left(strTo, 1) = "=" Then strTo = "'" & strTo
strFrom = .Sender
'//If sender displays name only, show name followed by email address e.g.(Bloggs, Joe < j.bloggs#mail.com >)
If InStr(1, strFrom, "#") < 1 Then strFrom = strFrom & " - < " & .SenderEmailAddress & " >"
dateSent = .SentOn
dateReceived = .ReceivedTime
strSubject = .Subject
spBody = Split(.Body, vbCrLf)
End With
'//Place information into spreadsheet
'//import information starting from last blank row in column A
With Range("C" & Rows.Count).End(xlUp).Offset(1, -2)
.Value = strTo
.Offset(0, 1).Value = strFrom
.Offset(0, 2).Value = strSubject
.Offset(0, 3).Resize(UBound(spBody) + 1, 1).Value = WorksheetFunction.Transpose(spBody)
.Offset(0, 4).Value = dateSent
.Offset(0, 5).Value = dateReceived
End With
'//Release item from memory
Set olMailItem = Nothing
End If
'//Next Item
Next loopControl
'//Release items from memory
Set olFolder = Nothing
Set olApp = Nothing
'//Resume screen updating
Application.ScreenUpdating = False
'//reset status bar
Application.StatusBar = False
'//Inform user that code has finished
MsgBox mailCount & " messages copied successfully.", vbInformation, "Complete"
End Sub
"but the mail content are not pasting in a single cell"
change:
Dim spBody As Variant
to:
Dim spBody As String
then change:
spBody = Split(.body, vbCrLf) '<--| Split() function is "splitting" the mail body into an array with as many elements as vbCrlf occurrences plus one
to:
spBody = .body
and finally change:
.Offset(0, 3).Resize(UBound(spBody) + 1, 1).Value = WorksheetFunction.Transpose(spBody) '<--| Resize() is "widening" the range to write values in to as many rows as 'spBody' array elements
to:
.Offset(0, 3).Value = spBody
I'm trying to build a macro that grabs a selection of cells from an Excel spreadsheet, pastes the cells into a new outlook email, then changes the format of the cells.
Specifically I want to convert the table to text, then change the font to Arial size 10.
The code below does the above, but I haven't been able to figure out how to convert the table to text, then change the text font.
Can anyone help?
Sub Email_test()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Set rng = Nothing
Set rng = Sheets("Master").Range("A1:B99").SpecialCells(xlCellTypeVisible)
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected. " & _
vbNewLine & "Please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = "User#company.com"
.CC = ""
.BCC = ""
.Subject = "Cells as text "
.HTMLbody = RangetoHTML(rng)
' In place of the following statement, you can use ".Display" to
' display the e-mail message.
.Display
End With
End Sub
This will work for you, instead of HTMLbody use body also removed your range to html function
Sub Email_test()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Set rng = Nothing
Set rng = Sheets("Master").Range("A1:B99").SpecialCells(xlCellTypeVisible)
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected. " & _
vbNewLine & "Please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Dim v As Variant: v = rng.Value
Dim tempStr As String: tempStr = ""
For i = LBound(v, 1) To UBound(v, 1)
For j = LBound(v, 2) To UBound(v, 2)
If j = 2 Then
tempStr = tempStr & v(i, j) & vbCrLf
Else
tempStr = tempStr & v(i, j) & " "
End If
Next j
Next i
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = "User#company.com"
.CC = ""
.BCC = ""
.Subject = "Cells as text "
.body = tempStr
' In place of the following statement, you can use ".Display" to
' display the e-mail message.
.Display
End With
End Sub
Please mark as an answer if you are satisfied with reply
The Outlook object model provides three main ways for working item bodies:
Body - a string representing the clear-text body of the Outlook item.
HTMLBody - a string representing the HTML body of the specified item.
Word editor - the Microsoft Word Document Object Model of the message being displayed. The WordEditor property of the Inspector class returns an instance of the Document class from the Word object model which you can use to set up the message body.
You can read more about all these ways in the Chapter 17: Working with Item Bodies. It us up to you which way is to choose.