mikes6058
asked on
edit body message - and insert a cell value - excel macro
Please could some one edit the code below so the body email will display exactly as below.
Note: *value of cell B2* = value of cell B2 on the active sheet when the macro is run
Note 2: The link in the body email has already been coded so that it is automatically inserted into the body of the email.
Body Message
Hi,
Please could you complete the action points found on the supplier meeting report (link below).
Once you have completed your action points please change the status from the drop down list found in column C/D and leave any relevant comments in the STAKEHOLDER COMMENTS column
Once completed please click the save & close button at the top of the page.
If you have any questions regarding your action points please contact the appropriate category manager found in cell E6 of the sheet
Please open the meeting report using the link below and select the meeting report link called *value of cell B2* found in column E
Click on the link below to open the file :
This is the link to to the file and will automatically be inserted
Regards,
Supplier Relationship team
Note: *value of cell B2* = value of cell B2 on the active sheet when the macro is run
Note 2: The link in the body email has already been coded so that it is automatically inserted into the body of the email.
Option Explicit
Sub SendEmail()
'///Set up the Excel variables.
Const MsgSignature As String = "Supplier Relationship Team"
Const sSubj As String = "Supplier Meeting Action Points"
Dim rCl As Range, rRng As Range
Dim OLApp As Object, olMailItm As Object
Dim iCnt As Integer
Dim sTo As String, sMsg As String
'///Create the Outlook application and the empty email.
Set OLApp = CreateObject("Outlook.Application")
Set olMailItm = OLApp.CreateItem(0)
'http://path/to/Workbook.xls#SheetName!a1
sMsg = "Hi,<br><br>" & _
"Please could you complete the action points found on the supplier meeting report (link below) <br><br>" & _
"Once you have completed your action points please change the status from the drop down list found in column C/D and leave any relevant comments in the STAKEHOLDER COMMENTS column.<br><br>" & _
"Once completed please click the save & close button at the top of the page.:<br><br>" & _
"If you have any questions regarding your action points please contact the appropriate category manager found in cell E6 of the sheet.:<br><br>" & _
"Click on the link to open the file :<br><br> " & _
"<A HREF=""file://" & ActiveWorkbook.FullName & "#" & ActiveSheet.Name & "!a1" & _
""">Link to the file</A>" & _
"<br><br>Regards," & _
"<br><br>" & MsgSignature
'/// create list of recipients
Set rRng = Range("B86:B93")
With olMailItm
For Each rCl In rRng.Cells
If rCl.Value > 0 Then
If sTo = "" Then
sTo = rCl.Value
Else
sTo = sTo & ";" & rCl.Value
End If
iCnt = iCnt + 1
End If
Next rCl
If iCnt < 2 Then
MsgBox "You nave not entered any recipients.", vbCritical, MsgSignature
Exit Sub
End If
.To = sTo
.Subject = sSubj
.HTMLBody = sMsg
.Display
' .Send
End With
'///Clean up the Outlook application.
Set olMailItm = Nothing
Set OLApp = Nothing
End SubBody Message
Hi,
Please could you complete the action points found on the supplier meeting report (link below).
Once you have completed your action points please change the status from the drop down list found in column C/D and leave any relevant comments in the STAKEHOLDER COMMENTS column
Once completed please click the save & close button at the top of the page.
If you have any questions regarding your action points please contact the appropriate category manager found in cell E6 of the sheet
Please open the meeting report using the link below and select the meeting report link called *value of cell B2* found in column E
Click on the link below to open the file :
This is the link to to the file and will automatically be inserted
Regards,
Supplier Relationship team
Option Explicit
Sub SendEmail()
'///Set up the Excel variables.
Const MsgSignature As String = "Supplier Relationship Team"
Const sSubj As String = "Supplier Meeting Action Points"
Dim rCl As Range, rRng As Range
Dim OLApp As Object, olMailItm As Object
Dim iCnt As Integer
Dim sTo As String, sMsg As String
'///Create the Outlook application and the empty email.
Set OLApp = CreateObject("Outlook.Application")
Set olMailItm = OLApp.CreateItem(0)
'http://path/to/Workbook.xls#SheetName!a1
sMsg = "Hi,<br><br>" & _
"Please could you complete the action points found on the supplier meeting report (link below) <br><br>" & _
"Once you have completed your action points please change the status from the drop down list found in column C/D and leave any relevant comments in the STAKEHOLDER COMMENTS column.<br><br>" & _
"Once completed please click the save & close button at the top of the page.:<br><br>" & _
"If you have any questions regarding your action points please contact the appropriate category manager found in cell E6 of the sheet.:<br><br>" & _
cells(2,2).value & _
"Click on the link to open the file :<br><br> " & _
"<A HREF=""file://" & ActiveWorkbook.FullName & "#" & ActiveSheet.Name & "!a1" & _
""">Link to the file</A>" & _
"<br><br>Regards," & _
"<br><br>" & MsgSignature
'/// create list of recipients
Set rRng = Range("B86:B93")
With olMailItm
For Each rCl In rRng.Cells
If rCl.Value > 0 Then
If sTo = "" Then
sTo = rCl.Value
Else
sTo = sTo & ";" & rCl.Value
End If
iCnt = iCnt + 1
End If
Next rCl
If iCnt < 2 Then
MsgBox "You nave not entered any recipients.", vbCritical, MsgSignature
Exit Sub
End If
.To = sTo
.Subject = sSubj
.HTMLBody = sMsg
.Display
' .Send
End With
'///Clean up the Outlook application.
Set olMailItm = Nothing
Set OLApp = Nothing
End Sub
Saurabh Singh Teotia
I'm not sure what you want to do here?? Can you help me connect what you are looking to do here..
Just to understand the 2 piece of code that you posted are the same right ? You posted the second one by mistake ? pls confirm.
gowflow
gowflow
Is this what you want ?
gowflow
Sub SendEmail()
On Error GoTo Errhandler
'///Set up the Excel variables.
Const MsgSignature As String = "Supplier Relationship Team"
Const sSubj As String = "Supplier Meeting Action Points"
Dim rCl As Range, rRng As Range
Dim OLApp As Object, olMailItm As Object
Dim iCnt As Integer
Dim sTo As String, sMsg As String
'///Create the Outlook application and the empty email.
Set OLApp = CreateObject("Outlook.Application")
Set olMailItm = OLApp.CreateItem(0)
'http://path/to/Workbook.xls#SheetName!a1
sMsg = "Hi,<br><br>" _
& "Please could you complete the action points found on the supplier meeting report (link below) <br><br>" _
& "Once you have completed your action points please change the status from the drop down list found in column C/D and leave any relevant comments in the STAKEHOLDER COMMENTS column.<br><br>" _
& "Once completed please click the save & close button at the top of the page.:<br><br>" _
& "If you have any questions regarding your action points please contact the appropriate category manager found in cell E6 of the sheet.:<br><br>" _
& "Please open the meeting report using the link below and select the meeting report link called " & Range("B2") & " found in column E<br><br>" _
& "Click on the link to open the file :<br><br> " _
& "<A HREF=""file://" & ActiveWorkbook.FullName & "#" & ActiveSheet.Name & "!a1" _
& """>Link to the file</A>" _
& "<br><br>Regards," _
& "<br><br>" & MsgSignature
'/// create list of recipients
Set rRng = Range("B86:B93")
With olMailItm
For Each rCl In rRng.Cells
If rCl.Value > 0 Then
If sTo = "" Then
sTo = rCl.Value
Else
sTo = sTo & ";" & rCl.Value
End If
iCnt = iCnt + 1
End If
Next rCl
If iCnt < 2 Then
MsgBox "You nave not entered any recipients.", vbCritical, MsgSignature
Exit Sub
End If
.To = sTo
.Subject = sSubj
.HTMLBody = sMsg
.Display
' .Send
End With
'///Clean up the Outlook application.
Set olMailItm = Nothing
Set OLApp = Nothing
Exit Sub
Errhandler:
MsgBox Error(Err)
Resume Next
End Subgowflow
ASKER
Hi Gowglow,
Yes your interpretation of my requirements was correct.
Stupidly I actually inserted the wrong code. Please could you apply exactly the same actions to the revised code below.
Mike
Yes your interpretation of my requirements was correct.
Stupidly I actually inserted the wrong code. Please could you apply exactly the same actions to the revised code below.
Option Explicit
Sub SendEmail()
'///Set up the Excel variables.
Const MsgSignature As String = "Supplier Relationship Team"
Const sSubj As String = "Supplier Meeting Action Points"
Dim rCl As Range, rRng As Range
Dim OLApp As Object, olMailItm As Object
Dim iCnt As Integer
Dim sTo As String, sMsg As String
'///Create the Outlook application and the empty email.
Set OLApp = CreateObject("Outlook.Application")
Set olMailItm = OLApp.CreateItem(0)
sMsg = "Hi,<br><br>" & _
"Please could you complete the action points found on the supplier meeting report (link below) <br><br>" & _
"Once you have completed your action points please change the status from the drop down list found in column C/D and leave any relevant comments in the STAKEHOLDER COMMENTS column.<br><br>" & _
"Once completed please click the save & close button at the top of the page.:<br><br>" & _
"If you have any questions regarding your action points please contact the appropriate category manager found in cell E6 of the sheet.:<br><br>" & _
"Click on the link to open the file :<br><br> " & _
"<A HREF=""file://" & ActiveWorkbook.FullName & _
""">Link to the file</A>" & _
"<br><br>Regards," & _
"<br><br>" & MsgSignature
'/// create list of recipients
Set rRng = Range("B86:B93")
With olMailItm
For Each rCl In rRng.Cells
If rCl.Value > 0 Then
If sTo = "" Then
sTo = rCl.Value
Else
sTo = sTo & ";" & rCl.Value
End If
iCnt = iCnt + 1
End If
Next rCl
If iCnt < 2 Then
MsgBox "You nave not entered any recipients.", vbCritical, MsgSignature
Exit Sub
End If
.To = sTo
.Subject = sSubj
.HTMLBody = sMsg
.Display
' .Send
End With
'///Clean up the Outlook application.
Set olMailItm = Nothing
Set OLApp = Nothing
End SubMike
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.