Send mail with respect to the value in a cell

[srinivasanyadhav]

Dear team,

Pls find attached .xlsx sheet.

I want code to send E-mail to a vendor if the value in "Column H" is less than "0".
with the details in "Column C to Column G" in a table.

To : E-mail id is in "Column J"
Cc : " xxx@gmail.com"
Subject line should be "Packing item - vendor name"

If more than one item is supplied by a vendor and the value in "Column H" is less than "0",
then we should group all the items in the table and send in one mail to them.

[HansV]

What should the e-mail look like?

[srinivasanyadhav]

Body of the message should be like,

Dear Sir - "Vendor Name"

Please find below the stock status :-

Table from "Column C to Column H"

Kindly supply the items which are below the re-order qty.

Thanks for your continuous support

Regards,

"Name"
Company
phone number

[srinivasanyadhav]

Dear HansV,

kindly make code without the rule "Column H is less than 0".
So that, the vendor will know the stock status of all items and plan the materials accordingly.

[HansV]

Here is a macro. It will only work with Outlook 2007 or later.

Code: Select all

Sub SendMessages()
    Const CompanyCol = "I"
    Const MailCol = "J"
    Const FirstRow = 3
    Dim LastRow As Long
    Dim CurRow As Long
    Dim EndRow As Long
    Dim Company As String
    Dim Email As String
    Dim StartedOL As Boolean
    Dim olApp As Object
    Dim olMsg As Object
    Dim olDoc As Object
    Dim olRng As Object

    On Error Resume Next
    Set olApp = GetObject(Class:="Outlook.Application")
    If olApp Is Nothing Then
        Set olApp = CreateObject(Class:="Outlook.Application")
        If olApp Is Nothing Then
            MsgBox "Cannot start Outlook!", vbExclamation
            Exit Sub
        End If
        StartedOL = True
    End If
    On Error GoTo ErrHandler
    olApp.Session.Logon

    LastRow = Range(CompanyCol & Rows.Count).End(xlUp).Row
    
    CurRow = FirstRow
    Do
        Company = Range(CompanyCol & CurRow).Value
        Email = Range(MailCol & CurRow).Value
        EndRow = CurRow
        Do While Range(CompanyCol & (EndRow + 1)).Value = Company
            EndRow = EndRow + 1
        Loop
        Set olMsg = olApp.CreateItem(0) ' olMailItem
        olMsg.Subject = "Invoice for " & Company
        olMsg.Display
        Set olDoc = olApp.ActiveInspector.WordEditor
        olDoc.Content.InsertAfter "Dear " & Replace(Company, vbLf, " ") & _
            vbCr & "Please find below the stock status." & vbCr & vbCr
        Set olRng = olDoc.Content
        olRng.Collapse Direction:=0 ' wdCollapseEnd
        Range("C" & CurRow & ":H" & EndRow).Copy
        olRng.Paste
        olDoc.Content.InsertAfter vbCr & _
            "Kindly supply the items which are below the re-order quantity." & _
            vbCr & vbCr & "Regards," & vbCr & "My Company"
        olMsg.Recipients.Add Email
        ' To test, open the message:
        ' For the final version, send it immediately:
        'olMsg.Send
        CurRow = EndRow + 1
    Loop Until CurRow > LastRow

ExitHandler:
    On Error Resume Next
    If StartedOL And Not olApp Is Nothing Then
        olApp.Quit
    End If
    Exit Sub

ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
End Sub

[srinivasanyadhav]

Dear Hans,

we need headers in the table.

Also the msg should be in Verdana font, size 10.

[HansV]

Code: Select all

Sub SendMessages()
    Const CompanyCol = "I"
    Const MailCol = "J"
    Const FirstRow = 3
    Dim LastRow As Long
    Dim CurRow As Long
    Dim EndRow As Long
    Dim Company As String
    Dim Email As String
    Dim StartedOL As Boolean
    Dim olApp As Object
    Dim olMsg As Object
    Dim olDoc As Object
    Dim olRng As Object

    On Error Resume Next
    Set olApp = GetObject(Class:="Outlook.Application")
    If olApp Is Nothing Then
        Set olApp = CreateObject(Class:="Outlook.Application")
        If olApp Is Nothing Then
            MsgBox "Cannot start Outlook!", vbExclamation
            Exit Sub
        End If
        StartedOL = True
    End If
    On Error GoTo ErrHandler
    olApp.Session.Logon

    LastRow = Range(CompanyCol & Rows.Count).End(xlUp).Row
    
    CurRow = FirstRow
    Do
        Company = Range(CompanyCol & CurRow).Value
        Email = Range(MailCol & CurRow).Value
        EndRow = CurRow
        Do While Range(CompanyCol & (EndRow + 1)).Value = Company
            EndRow = EndRow + 1
        Loop
        Set olMsg = olApp.CreateItem(0) ' olMailItem
        olMsg.Subject = "Invoice for " & Company
        olMsg.Display
        Set olDoc = olApp.ActiveInspector.WordEditor
        olDoc.Content.Font.Name = "Verdana"
        olDoc.Content.Font.Size = 10
        olDoc.Content.InsertAfter "Dear " & Replace(Company, vbLf, " ") & _
            vbCr & "Please find below the stock status." & vbCr & vbCr
        Set olRng = olDoc.Content
        olRng.Collapse Direction:=0 ' wdCollapseEnd
        Range("C2:H2,C" & CurRow & ":H" & EndRow).Copy
        olRng.Paste
        olDoc.Content.InsertAfter vbCr & _
            "Kindly supply the items which are below the re-order quantity." & _
            vbCr & vbCr & "Regards," & vbCr & "My Company"
        olMsg.Recipients.Add Email
        ' To test, open the message:
        ' For the final version, send it immediately:
        'olMsg.Send
        CurRow = EndRow + 1
    Loop Until CurRow > LastRow

ExitHandler:
    On Error Resume Next
    If StartedOL And Not olApp Is Nothing Then
        olApp.Quit
    End If
    Exit Sub

ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
End Sub

[srinivasanyadhav]

All the rows are picked up now. Company wise details not coming.

[HansV]

Not when I run the code:

S276.png

[srinivasanyadhav]

Kindly check for other companies.

[HansV]

I see. The code included everything from the header row to the data for the company.

Code: Select all

Sub SendMessages()
    Const CompanyCol = "I"
    Const MailCol = "J"
    Const FirstRow = 3
    Dim LastRow As Long
    Dim CurRow As Long
    Dim EndRow As Long
    Dim Company As String
    Dim Email As String
    Dim StartedOL As Boolean
    Dim olApp As Object
    Dim olMsg As Object
    Dim olDoc As Object
    Dim olRng As Object

    On Error Resume Next
    Set olApp = GetObject(Class:="Outlook.Application")
    If olApp Is Nothing Then
        Set olApp = CreateObject(Class:="Outlook.Application")
        If olApp Is Nothing Then
            MsgBox "Cannot start Outlook!", vbExclamation
            Exit Sub
        End If
        StartedOL = True
    End If
    On Error GoTo ErrHandler
    olApp.Session.Logon

    LastRow = Range(CompanyCol & Rows.Count).End(xlUp).Row
    
    CurRow = FirstRow
    Do
        Company = Range(CompanyCol & CurRow).Value
        Email = Range(MailCol & CurRow).Value
        EndRow = CurRow
        Do While Range(CompanyCol & (EndRow + 1)).Value = Company
            EndRow = EndRow + 1
        Loop
        Set olMsg = olApp.CreateItem(0) ' olMailItem
        olMsg.Subject = "Invoice for " & Company
        olMsg.Display
        Set olDoc = olApp.ActiveInspector.WordEditor
        olDoc.Content.Font.Name = "Verdana"
        olDoc.Content.Font.Size = 10
        olDoc.Content.InsertAfter "Dear " & Replace(Company, vbLf, " ") & _
            vbCr & "Please find below the stock status." & vbCr & vbCr
        Set olRng = olDoc.Content
        olRng.Collapse Direction:=0 ' wdCollapseEnd
        Range("C2:H2").Copy
        olRng.Paste
        Set olRng = olDoc.Content
        olRng.Collapse Direction:=0 ' wdCollapseEnd
        Range("C" & CurRow & ":H" & EndRow).Copy
        olRng.Paste
        olDoc.Content.InsertAfter vbCr & _
            "Kindly supply the items which are below the re-order quantity." & _
            vbCr & vbCr & "Regards," & vbCr & "My Company"
        olMsg.Recipients.Add Email
        ' To test, open the message:
        ' For the final version, send it immediately:
        'olMsg.Send
        CurRow = EndRow + 1
    Loop Until CurRow > LastRow

ExitHandler:
    On Error Resume Next
    If StartedOL And Not olApp Is Nothing Then
        olApp.Quit
    End If
    Exit Sub

ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
End Sub

[srinivasanyadhav]

cc address??

[HansV]

See Post=123905

[Rudi]

Or this post...if the syntax is different for Excel
http://www.mrexcel.com/forum/excel-ques ... post504085

[srinivasanyadhav]

Dear hans,
I used the command from the program already.
But it is added in the to field only.

Const CCAddress = "123@123.com "

olMsg.Recipients.Add(CCAddress).Type = 2 ' olCC

Anything I should change here?

[srinivasanyadhav]

Dear Hans & Rudi,

I understood. thank u for your great help.
you people inspired me.

Now I started learning VB. Can u suggest a good e-book, which I can start with?

Thank u:)

[HansV]

You'll find a series of tutorials for Excel VBA at Excel-Easy.

[Rudi]

See this post too: Post # 124197

[HansV]

But it is added in the to field only.

Move the line

Code: Select all

    Const CCAddress = "123@123.com"

to the beginning of the macro, and move the lines

Code: Select all

        olMsg.Recipients.Add Email
        olMsg.Recipients.Add(CCAddress).Type = 2 ' olCC

to immediately below the line

Code: Select all

        Set olMsg = olApp.CreateItem(0) ' olMailItem

[srinivasanyadhav]

Dear Hans,

I am using the below code for the attached excel sheet.
By this all the rows are selected for mail list.
But now I need only the rows, which have values in "Column D".
Could you help on this?

Code: Select all

Sub SendOilStock()
    Const CompanyCol = "E"
    Const MailCol = "F"
    Const FirstRow = 3
    Dim LastRow As Long
    Dim CurRow As Long
    Dim EndRow As Long
    Dim Company As String
    Dim Email As String
    Dim StartedOL As Boolean
    Dim olApp As Object
    Dim olMsg As Object
    Dim olDoc As Object
    Dim olRng As Object

    On Error Resume Next
    Set olApp = GetObject(Class:="Outlook.Application")
    If olApp Is Nothing Then
        Set olApp = CreateObject(Class:="Outlook.Application")
        If olApp Is Nothing Then
            MsgBox "Cannot start Outlook!", vbExclamation
            Exit Sub
        End If
        StartedOL = True
    End If
    On Error GoTo ErrHandler
    olApp.Session.Logon

    LastRow = Range(CompanyCol & Rows.Count).End(xlUp).Row
    
    CurRow = FirstRow
    Do
        Company = Range(CompanyCol & CurRow).Value
        Email = Range(MailCol & CurRow).Value
        EndRow = CurRow
        Do While Range(CompanyCol & (EndRow + 1)).Value = Company
            EndRow = EndRow + 1
        Loop
        Set olMsg = olApp.CreateItem(0) ' olMailItem
        olMsg.Subject = "Oil Need for today -  " & Company
        olMsg.Display
        Set olDoc = olApp.ActiveInspector.WordEditor
        olDoc.Content.Font.Name = "Verdana"
        olDoc.Content.Font.Size = 10
        olDoc.Content.InsertAfter "Dear Sir - " & Replace(Company, vbLf, " ") & _
            vbCr & "Please find below the Oil need today for ILJIN." & vbCr & vbCr
        Set olRng = olDoc.Content
        olRng.Collapse Direction:=0 ' wdCollapseEnd
        Range("A2:D2").Copy
        olRng.Paste
        Set olRng = olDoc.Content
        olRng.Collapse Direction:=0 ' wdCollapseEnd
        Range("A" & CurRow & ":D" & EndRow).Copy
        olRng.Paste
        olDoc.Content.InsertAfter vbCr & _
            "Kindly supply the items before 4.30 P.M. CONTACT : MR.KOTHANDAM (PRODUCTION DEPT) @ 4710 2154 OR 98410 50173 for Unloading" & _
            vbCr & vbCr & "Regards," & vbCr & "Srinivasan" & vbCr & "ILJIN AUTOMOTIVE" & vbCr & "JR.OFFICER" & vbCr & "G-PURCHASE" & vbCr & "PH:98416 77464"
        olMsg.Recipients.Add Email
        ' Add CC
        olMsg.cc = "mohan@iljin.com;kr@iljin.com;kothandam@iljin.com"
        
        ' To test, open the message:
        ' For the final version, send it immediately:
        'olMsg.Send
        CurRow = EndRow + 1
    Loop Until CurRow > LastRow

ExitHandler:
    On Error Resume Next
    If StartedOL And Not olApp Is Nothing Then
        olApp.Quit
    End If
    Exit Sub

ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
End Sub