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 'close' button found under the SUPPLIER MEETINGS tab 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 below to open the file (Click 'Ok' and 'Continue' to all prompts when opening 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 Exit Sub Errhandler: MsgBox Error(Err) Resume Next End Sub
Option Explicit Sub NewCode() ''/// the sheet name will need to be changed to actual name used in the final workbook If ActiveSheet.Name = "Stakeholder_Actionpoints" Then MsgBox "You have the rsults sheet active.", vbCritical, "Error" Exit Sub End If Dim ws As Worksheet Dim rToCopy As Range Dim lRw As Long Dim iX As Integer '1. Copy all values (including blank cell values) from the range A14:E18 and paste under the relevant column headings found in sheet Stakeholder_Actionpoints Set ws = ActiveSheet Set rToCopy = ws.Range(Cells(14, 1), Cells(18, 5)) With Sheet55 lRw = .Cells(.Rows.Count, 1).End(xlUp).Row + 1 rToCopy.Columns(1).Copy Application.Goto .Cells(lRw, 2) ActiveSheet.Paste Link:=True rToCopy.Columns(2).Copy Application.Goto .Cells(lRw, 1) ActiveSheet.Paste Link:=True rToCopy.Columns(3).Copy Application.Goto .Cells(lRw, 5) ActiveSheet.Paste Link:=True rToCopy.Columns(5).Copy Application.Goto .Cells(lRw, 3) ActiveSheet.Paste Link:=True rToCopy.Columns(6).Copy Application.Goto .Cells(lRw, 4) ActiveSheet.Paste Link:=True For iX = 1 To rToCopy.Rows.Count .Hyperlinks.Add Anchor:=.Cells(lRw, 6), Address:="", SubAddress:= _ "'" & ws.Name & "'!A" & iX + 13, TextToDisplay:=ws.Name lRw = lRw + 1 Next iX End With End Sub
From novice to tech pro — start learning today.