• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Auto Email for roster

Dear Team,

Thank you for your support always.

need help to send roster to my team monthly, i need to copy the range paste it outlook and then send the email.

Can it would be possible to just click on the email address on cell T4 and it auto select the range A1:S3 and range A4:S4 for that Agent and open outlook to send email

or any other shortcut would be really helpful as i have team on 60 staff and need to spend almost 2 hours to send the roster.

Many Thanks
Mohamed Sameer
 

Attachments

Keetoowah

New Member
Hi Mohamed Sameer,
try this code:
Code:
Sub SendRoster()

    Dim Header As Range
    Dim MyAgent As Range
    Dim MyMailBody As Range
    Dim OutApp As Object
    Dim OutMail As Object
    Dim i As Integer
    Dim LastRow As Integer

    LastRow = Cells(Rows.Count, 1).End(xlUp).Row

    Set Header = ActiveSheet.Range("A1:S3")

    Application.ScreenUpdating = False

    For i = 4 To LastRow
        Set MyAgent = ActiveSheet.Range(Cells(i, 1), Cells(i, 19))
        Union(Header, MyAgent).Select

        Set MyMailBody = Selection

        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)

        On Error Resume Next
       
        With OutMail
            .To = Range("T" & i).Value
       
            .Subject = "Roster month..."
            .HTMLBody = "Please find..." & "<br>" & RangetoHTML(MyMailBody) & "<br>" & "Best regards."
            .Display
           ' use .Send to send it automatically
                 
        End With
    Next i

    Set OutMail = Nothing
    Set OutApp = Nothing

    Application.ScreenUpdating = True

End Sub

Function RangetoHTML(MyMailBody As Range)
   
    Dim fso As Object, ts As Object, TempWB As Workbook, TempFile As String

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

    MyMailBody.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteAllUsingSourceTheme, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
    End With
    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
    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=")

    TempWB.Close 0
    Kill TempFile

    Set ts = Nothing: Set fso = Nothing: Set TempWB = Nothing
   
End Function

See attached sample
 

Attachments

Last edited by a moderator:
Hi Keetoowah,

Thank you your quick response.

I tired putting the code and click on send button, nothing is happening it just give me a click.

also i check the setting for macro enable etc..

file enclosed..

please suggest

Many Thanks
Mohamed sameer
 

Attachments

Top