How to copy corresponding range of cells when a cell reaches a certain value in an email

[phryx8]

Hi guys,

I've been searching on web to find a solution to my problem but have only found variations so far.
So I need excel to automatically send an email when a cell in column X changes from "Y" to "N".
In that email I need the corresponding row only be copied into the email.

So say cell X3 changes from "N" to "Y" then I need the corresponding range of cells A3:X3 (or X4 then A4:X4 and so on) to be copied into the body of an email.

Here is what I have so far:

For the Trigger event:

Option Explicit


Private Sub Worksheet_Calculate()
    Dim FormulaRange As Range
    Dim NotSentMsg As String
    Dim MyMsg As String
    Dim SentMsg As String
    Dim Completed As String


    NotSentMsg = "Not Sent"
    SentMsg = "Sent"




    Completed = "Y"


    Set FormulaRange = Me.Range("X3:X7")


    On Error GoTo EndMacro:
    For Each FormulaCell In FormulaRange.Cells
        With FormulaCell
            If IsString(.Value) = False Then
                MyMsg = "Not in required format"
            Else
                If .Value = "Y" Then
                    MyMsg = SentMsg
                    If .Offset(0, 1).Value = NotSentMsg Then
                        Call Outlookcomposetrigger
                    End If
                Else
                    MyMsg = NotSentMsg
                End If
            End If
            Application.EnableEvents = False
            .Offset(0, 1).Value = MyMsg
            Application.EnableEvents = True
        End With
    Next FormulaCell


ExitMacro:
    Exit Sub


EndMacro:
    Application.EnableEvents = True


    MsgBox "Some Error occurred." _
         & vbLf & Err.Number _
         & vbLf & Err.Description


End Sub

Then the actual macro to compose my email.....

Sub Outlookcomposetrigger()


    Dim OutApp As Object
    Dim OutMail As Object
    Dim strto As String, strcc As String, strbcc As String
    Dim strsub As String, strbody As String
    Dim Rng As Range


Set Rng = Nothing
    On Error Resume Next
    


    
Set Rng = Cells(FormulaCell.Row, "A:X").Value 'SpecialCells(xlCellTypeVisible)






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


    strto = "mrpbody.gmail.com"
    strcc = ""
    strbcc = ""
    strsub = "Your subject"
    strbody = "Hi Mr P Body" & vbNewLine & vbNewLine & _
              "Stock has reached critical levels. Have a look below"


    With OutMail
        .To = strto
        .CC = strcc
        .BCC = strbcc
        .Subject = strsub
        .HTMLBody = strbody & RangetoHTML(Rng) & vbNewLine & "Kind Regards," & .HTMLBody
        'You can add a file to the mail like this
        '.Attachments.Add ("C:\test.txt")
        .Display    ' or use .Send
    End With


    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub


Function RangetoHTML(Rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2013
    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

Any help or guidance would be helpful guys.

Cheers,
Phil

 

[phryx8]

I am using Excel 2007 if that helps

 

[phryx8]

Hi again all,
I found the solution.
A simple ActiveCell.Offset and resize to refer to the range on the same row.
Cheers,
Phil