Send mail with respect to the value in a cell

[HansV]

Try this version:

Code: Select all

Sub SendOilStock()
    Const LiterCol = "D"
    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
    Dim Counter As Long

    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
        Set olMsg = olApp.CreateItem(0) ' olMailItem
        olMsg.Subject = "Oil Need for today -  " & Company
        olMsg.Recipients.Add Email
        ' Add CC
        olMsg.cc = "mohan@iljin.com;kr@iljin.com;kothandam@iljin.com"
        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
        Counter = 0
        If Range(LiterCol & EndRow).Value <> "" Then
            Range("A" & EndRow & ":D" & EndRow).Copy
            Set olRng = olDoc.Content
            olRng.Collapse Direction:=0 ' wdCollapseEnd
            olRng.Paste
            Counter = Counter + 1
        End If
        Do While Range(CompanyCol & (EndRow + 1)).Value = Company
            EndRow = EndRow + 1
            If Range(LiterCol & EndRow).Value <> "" Then
                Range("A" & EndRow & ":D" & EndRow).Copy
                Set olRng = olDoc.Content
                olRng.Collapse Direction:=0 ' wdCollapseEnd
                olRng.Paste
                Counter = Counter + 1
            End If
        Loop
        If Counter = 0 Then
            olApp.ActiveInspector.Close 1
        Else
            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"
        End If
        CurRow = EndRow + 1
        MsgBox "Click OK to continue with next vendor", vbInformation
    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]

Thank you Hans.
I don't want that error msg to display to continue to next supplier.

[srinivasanyadhav]

Hans,

I did that on my own.
Thank u for your help.