Vba to copy cells and paste into outlook

[thedeadzeds]

Hi all,

I have a spreadsheet that I would like to copy and paste information into an email and then send that email to a specific person based on a value that is entered in that cell. Not sure if this is possible but the attached spreadsheet should help explain this. Cell L4 populates with the text 'Urgent' if cell K4 is equal to A4.

When Cell L4 shows 'Urgent', can excel copy cells A4 to Q4 and paste them in an email, and then send it to a specific email address.

The only other thing to consider is that I would want this to work every time Urgent is populated so for example:

When Cell L5 shows 'Urgent', can excel copy cells A5 to Q5 and paste them in an email, and then send it to a specific email address.
When Cell L6 shows 'Urgent', can excel copy cells A6 to Q6 and paste them in an email, and then send it to a specific email address.
When Cell L7 shows 'Urgent', can excel copy cells A7 to Q7 and paste them in an email, and then send it to a specific email address.
AND SO ON.........

Thanks in advance

[Ken Puls]

Hi there, and welcome to the forum.

Yes, absolutley. A few questions though...
1) How would you like this triggered? Press a button and it sends an email to everyone that is URGENT, or did you want to do it one person at a time?
2) Are you Microsoft Outlook as your email client, or something else?
3) What version of Excel are you using?
4) Where will the email addresses of the person/people to send to be stored? (Hopefully in a column, but which one?)

[thedeadzeds]

Thaks Vrey much

Yes, absolutley. A few questions though...
1) How would you like this triggered? Press a button and it sends an email to everyone that is URGENT, or did you want to do it one person at a time?

One person at a time

2) Are you Microsoft Outlook as your email client, or something else?

Micorsoft Outlook

3) What version of Excel are you using?

2003
4) Where will the email addresses of the person/people to send to be stored? (Hopefully in a column, but which one?)


Any column is fine as long as its not got anything esle in it

Many thanks for this

[Ken Puls]

I'll see what I can cobble together for you tomorrow on this. :)

[thedeadzeds]

Thanks v much its really appreciated

[Ken Puls]

Okay, try this. Email addresses need to be placed in column Q (although you can easily change that in the code):


Sub SendEmail()
'Macro Purpose: To send an email through Outlook
Dim objOL As Object
Dim objMail As Object
Dim sEmail As String
Dim sEmailColumn As String
Dim sSubject As String
Dim sBody As String
Dim lDataRow As Long
Dim cl As Range
'Set column with email address
sEmailColumn = "Q"
For Each cl In Selection.Resize(, 1)
'Generate required info
lDataRow = cl.Row
'Check if remediation required
If cl.Parent.Range("L" & lDataRow).Value = "Urgent" Then
With cl.Parent
sEmail = .Range(sEmailColumn & lDataRow)
sSubject = "Agreement " & .Range("B" & lDataRow) & " requires urgent remediation!"
sBody = "Remediation Required:" & vbNewLine & .Range("H" & lDataRow) & _
vbNewLine & vbNewLine & "Advisors Comments:" & vbNewLine & .Range("N" & lDataRow) & _
vbNewLine & vbNewLine & "Management Comments:" & vbNewLine & .Range("O" & lDataRow)
End With
'Turn on error handling
On Error GoTo Cleanup
'Bind to Outlook
Set objOL = CreateObject("Outlook.Application")
'Create a new email and send it
Set objMail = objOL.CreateItem(0) '0=olmailitem
With objMail
.To = sEmail
.Subject = sSubject
.Body = sBody
.Display
End With
End If
Next cl
Cleanup:
'Release all objects
Set objMail = Nothing
Set objOL = Nothing
On Error GoTo 0
End Sub


Once that code is pasted into a standard module, you can select any cell, press Alt+F8 and run the macro. It should create the email for you. If you select a group of cells, it will create an email for each line where remediation is Urgent.

If you'd like it to send automatically, without creating the preview first, change ".Display" to ".Send"

[thedeadzeds]

works like a treat.....I cant thank you enough.

Very much appreciated
Thanks

[ankit_kuchhal]

Hi Ken,

Can you please help me with a similar problem? I want to write a code where predefined cells are copied and sent in a mail. Attached in the code which i have written:
Dim objOL As Object
Dim objMail As Object
Dim sEmail As String
Dim sSubject As String
Dim sBody As String
Dim lDataRow As Long
Dim cl As Range
Set b = Range("B2:B100").Find("WHITE", LookIn:=xlValues)
MyRow = b.Row
sSubject = "Test Execution status as of " & Cells(6, 3) & " for " & Cells(7, 3)
sBody = Range("B2:K" & MyRow).Select

'Turn on error handling
On Error GoTo Cleanup
'Bind to Outlook
Set objOL = CreateObject("Outlook.Application")
'Create a new email and send it
Set objMail = objOL.CreateItem(0) '0=olmailitem
With objMail
.Subject = sSubject
.Body = sBody
.Display
End With
Cleanup:
'Release all objects
Set objMail = Nothing
Set objOL = Nothing
On Error GoTo 0
End Sub

Here when i execute the code, "True" is coming in body of mail while i want the copied cells to be in the mail. What should i do to copy my selected range.

Thanks,
Ankit




Okay, try this. Email addresses need to be placed in column Q (although you can easily change that in the code):


Sub SendEmail()
'Macro Purpose: To send an email through Outlook
Dim objOL As Object
Dim objMail As Object
Dim sEmail As String
Dim sEmailColumn As String
Dim sSubject As String
Dim sBody As String
Dim lDataRow As Long
Dim cl As Range
'Set column with email address
sEmailColumn = "Q"
For Each cl In Selection.Resize(, 1)
'Generate required info
lDataRow = cl.Row
'Check if remediation required
If cl.Parent.Range("L" & lDataRow).Value = "Urgent" Then
With cl.Parent
sEmail = .Range(sEmailColumn & lDataRow)
sSubject = "Agreement " & .Range("B" & lDataRow) & " requires urgent remediation!"
sBody = "Remediation Required:" & vbNewLine & .Range("H" & lDataRow) & _
vbNewLine & vbNewLine & "Advisors Comments:" & vbNewLine & .Range("N" & lDataRow) & _
vbNewLine & vbNewLine & "Management Comments:" & vbNewLine & .Range("O" & lDataRow)
End With
'Turn on error handling
On Error GoTo Cleanup
'Bind to Outlook
Set objOL = CreateObject("Outlook.Application")
'Create a new email and send it
Set objMail = objOL.CreateItem(0) '0=olmailitem
With objMail
.To = sEmail
.Subject = sSubject
.Body = sBody
.Display
End With
End If
Next cl
Cleanup:
'Release all objects
Set objMail = Nothing
Set objOL = Nothing
On Error GoTo 0
End Sub


Once that code is pasted into a standard module, you can select any cell, press Alt+F8 and run the macro. It should create the email for you. If you select a group of cells, it will create an email for each line where remediation is Urgent.

If you'd like it to send automatically, without creating the preview first, change ".Display" to ".Send"

[Ken Puls]

ankit, are you still looking for help with this?

[awillard006]

Ken,
I know this thread is pretty old but it references exactly the problem I am trying to solve. Basically I would like to open a new email in Outlook (Outlook will be open already) and then copy in a specified range of cells into the email (ie range("A1:F60")). The cells do not need to be selected beforehand. I do have some merged cells within this range. Any help would be greatly appreciated, thanks!

[awillard006]

I was able to get this working using another html function as seen below :)


Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2010
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook

TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With

Dim HyperL As Hyperlink
For Each HyperL In rng.Hyperlinks
TempWB.Sheets(1).Hyperlinks.Add _
Anchor:=TempWB.Sheets(1).Range(HyperL.Range.Address), _
Address:=HyperL.Address, _
TextToDisplay:=HyperL.TextToDisplay
Next HyperL

'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With

'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center xlPublishsource=", _
"align=left xlPublishsource=")

'Close TempWB
TempWB.Close savechanges:=False

'Delete the htm file we used in this function
Kill TempFile

Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
Sub SendEmail()
'Macro Purpose: To send an email through Outlook
Dim rng As Range
Dim ToEmailList As String
Dim CcEmailList As String
Dim sSubject As String

ToEmailList = "test.com"
CcEmailList = "Blah.com; haha.com"
sSubject = "sums"

Set OutApp = GetObject(, "Outlook.Application")
If OutApp Is Nothing Then Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Set rng = Sheets("Email").Range("A1:F" & ThisWorkbook.Worksheets("Email").UsedRange.Rows.Count)

With OutMail
.To = ToEmailList
.Cc = CcEmailList
.Subject = sSubject
.HTMLBody = RangetoHTML(rng)
.Display
End With
End Sub

[thedeadzeds]

Hi Ken,

I appreciate this is old but I was wondering if there was a way to change the original code. We have been using it sucessfully for a year and It works great but in order for the email to be sent, you need to place the mouse on 'urgent' in column L and then run the macro. Is there a way to send the email as soon as the cells reads 'urgent' rather than manually doing it or running any macros manually?

Kind regards
Craig


Sub SendEmail()
'Macro Purpose: To send an email through Outlook
Dim objOL As Object
Dim objMail As Object
Dim sEmail As String
Dim sEmailColumn As String
Dim sSubject As String
Dim sBody As String
Dim lDataRow As Long
Dim cl As Range
'Set column with email address
sEmailColumn = "Q"
For Each cl In Selection.Resize(, 1)
'Generate required info
lDataRow = cl.Row
'Check if remediation required
If cl.Parent.Range("L" & lDataRow).Value = "Urgent" Then
With cl.Parent
sEmail = .Range(sEmailColumn & lDataRow)
sSubject = "Agreement " & .Range("B" & lDataRow) & " requires urgent remediation!"
sBody = "Remediation Required:" & vbNewLine & .Range("H" & lDataRow) & _
vbNewLine & vbNewLine & "Advisors Comments:" & vbNewLine & .Range("N" & lDataRow) & _
vbNewLine & vbNewLine & "Management Comments:" & vbNewLine & .Range("O" & lDataRow)
End With
'Turn on error handling
On Error GoTo Cleanup
'Bind to Outlook
Set objOL = CreateObject("Outlook.Application")
'Create a new email and send it
Set objMail = objOL.CreateItem(0) '0=olmailitem
With objMail
.To = sEmail
.Subject = sSubject
.Body = sBody
.Display
End With
End If
Next cl
Cleanup:
'Release all objects
Set objMail = Nothing
Set objOL = Nothing
On Error GoTo 0
End Sub

[Ken Puls]

Untested, but... add the following to the worksheet module for whichever sheet you are entering the data on:


Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Target.Parent.Columns("L:L")) Is Nothing Then
If LCase(Target.Value) = "urgent" Then Call SendSelectedMailOnly(Target)
End If
End Sub

Then add the following to a standard module:

Public Sub SendSelectedMailOnly(cl As Range)
'Macro Purpose: To send an email through Outlook
Dim objOL As Object
Dim objMail As Object
Dim sEmail As String
Dim sEmailColumn As String
Dim sSubject As String
Dim sBody As String
'Set column with email address
sEmailColumn = "Q"
'Check if remediation required
With cl.Parent
sEmail = .Range(sEmailColumn & cl.Row)
sSubject = "Agreement " & .Range("B" & cl.Row) & " requires urgent remediation!"
sBody = "Remediation Required:" & vbNewLine & .Range("H" & cl.Row) & _
vbNewLine & vbNewLine & "Advisors Comments:" & vbNewLine & .Range("N" & cl.Row) & _
vbNewLine & vbNewLine & "Management Comments:" & vbNewLine & .Range("O" & cl.Row)
End With

'Turn on error handling
On Error GoTo Cleanup

'Bind to Outlook
Set objOL = CreateObject("Outlook.Application")

'Create a new email and send it
Set objMail = objOL.CreateItem(0) '0=olmailitem

With objMail
.To = sEmail
.Subject = sSubject
.Body = sBody
.Display
End With
Cleanup:
'Release all objects
Set objMail = Nothing
Set objOL = Nothing
On Error GoTo 0

End Sub
HTH,

[thedeadzeds]

Ken, works like a charm, the only small thing is I get this warning message and have to click yes in order for the email to send. No sure if there is a way around this

'A programme is trying to automatically send email on your behalf. Do you want to allow this? If this is unexpected, it may be a virus and you should choose "No"

1341

[Ken Puls]

If you're on Office 2003 or earlier, then you pretty much have two options: Buy a copy of Outlook Redemption, and code against that, or download a (free) copy of ClickYes, and use that to click the button for you, as described in this article (http://www.excelguru.ca/content.php?174). If you're on 2007 or later, I thought that issue went away when you have a proper antivirus suite installed...