VBA to pick up email id and paste in TO field.

HELLO,

Any help is appreciated. I think my problem can be solved by vba vlookup.

  ‘ In Sheet 2: Col A contain employee No. & Col B contain their respective email ID’s ‘ In Sheet 1: col D contain employee No.

Requirement in VBA: When data is selected in any row (or multiple discrete rows) from col A to col D, (eg. A4:D4, A7:D7 & A10:D10 together), and the MACRO (Send email) is executed.

In draft email display, in “TO” field, IT should automatically pull the corresponding and unique email ID’s against the employee no. in those selected rows i.e., email id for employee no. EMP2(D4) & EMP4(D10).

‘ Actual data is like there are 18 to 20 email ID’s in sheet 2 ‘ But in sheet 1: data in 4000 rows and 35 column.

 I must tell you that I DONT KNOW ANYTHING ABOUT VBA CODING. But to speed up my work I searched through many forums and build up a code by mix and match, copy-paste…basically hit & trial method, which is working fine.

 

Option Explicit

 

Sub Send_Email()

 

‘ In Sheet 2: Col A contain employee No. & Col B contain their respective email ID’s

‘ In Sheet 1: col D contain employee No.

‘ Employee No. is dependent on corresponding value in Col ‘C’. If any cell in Col C has any value, there must be an employee No. in Col D.

‘ Requirement in VBA: When data is selected in any row (or multiple discrete rows) from col A to col D,

    ‘(eg. A4:D4, A7:D7 & A10:D10 together), and the MACRO (Send email) is executed.

    ‘In draft email display, in “TO” field,  should automatically pull the corresponding and unique email ID’s

    ‘against the employee no. in those selected rows i.e., email id for employee no. EMP2(D4) & EMP4(D10).

‘ Actual data is like there are 18 to 20 email ID’s in sheet 2

‘ But in sheet 1: data in 4000 rows and 35 column.

 

    Dim rng As Range

    Dim rng2 As Range

    Dim Urng As Range

    Dim OutApp As Object

    Dim OutMail As Object

    Dim StrBody As String

 

    With Sheet1

 

    StrBody = “<H3><B>Dear Team,</B></H3>” & _

              “Line-1.<br>” & _

              “Line-2.<br>” & _

              “<br><br><B>Thank you</B>”

 

    Set rng = Nothing

    On Error Resume Next

    ‘Only the visible cells in the selection

    Set rng = .Range(“A2:D2”).SpecialCells(xlCellTypeVisible)

    Set rng2 = Selection.SpecialCells(xlCellTypeVisible)

    Set Urng = Union(rng, rng2)

 

    On Error GoTo 0

 

    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)

 

    On Error Resume Next

    With OutMail

        .To = “” ‘

        .CC = “”

        .BCC = “”

        .Subject = “”

        .HTMLBody = StrBody & RangetoHTML(Urng)

        .display   ‘use .send or .Display

    End With

    On Error GoTo 0

 

    With Application

        .EnableEvents = True

        .ScreenUpdating = True

    End With

 

    Set OutMail = Nothing

    Set OutApp = Nothing

    End With

End Sub

 

 

Function RangetoHTML(rng As Range)

‘ Changed by Ron de Bruin 28-Oct-2006

‘ Working in Office 2000-2016

    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

 

    ‘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 x:publishsource=”, _

                          “align=left x:publishsource=”)

 

    ‘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

 

 

 

 

 

 

 

 

By: GtScorp

Leave a Reply

Your email address will not be published. Required fields are marked *