Automatically send email when cell changes valaue

[emoandy05]

Hello,

Thanks in advance for your help.

Every time cell J10 changes value and is greater than 0, I would like an email to be sent via outlook. Recipients are in cell E2, Subject is in cell E3, and the body of the email is a chart (to be pasted as a picture) in cells D8:H18.

The value in cell J10 will update change throughout the day. So long as the spreadsheet is open, I would like the email to be sent.

Thank you for your help!

Please let me know if I can provide any clarification.

 

[emoandy05]

My code worked, but i had to hit the play button. My code is in Sheet 1 under Objects.

How can i get the email to automatically send when J10 changes? J10 is a formula.

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim response
    If Target.Address = "$J$10" And Target.Value <> 0 Then
        
            Dim AWorksheet As Worksheet
            Dim Sendrng As Range
            Dim to1 As Range
            Dim subj1 As Range
        
            Set to1 = Worksheets("Sheet1").Range("E2")
 
            Set subj1 = Worksheets("Sheet1").Range("E3")

            On Error GoTo StopMacro

            With Application
                .ScreenUpdating = False
                .EnableEvents = False
            End With

            Set Sendrng = Worksheets("Sheet1").Range("D8:H18")

            Set AWorksheet = ActiveSheet

            With Sendrng

            .Parent.Select

            Set Rng = ActiveCell

            .Select

            ActiveWorkbook.EnvelopeVisible = True
                With .Parent.MailEnvelope

                With .Item
                    .to = to1
                    .Subject = subj1
                    .body = body1
                    .Send
                End With

            End With

            Rng.Select
            End With

            AWorksheet.Select

StopMacro:
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    ActiveWorkbook.EnvelopeVisible = False
    
        
End If

End Sub

 

[ColdGeorge]

Hi emoandy05

I use this code, give it a try:

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect([A1], Target) Is Nothing Then
Set olapp = CreateObject("Outlook.application")
Set m = olapp.CreateItem(olMailItem)
    
With m
.To = "anyperson@anmyplace.com"
.CC = ""
.BCC = ""
.Subject = "Any message"
.Body = "Any message"
 
'.Attachments.Add ActiveWorkbook.FullName
'.Display
.Send
End With
      
Set olapp = Nothing
Set m = Nothing
       
End If
End Sub

ColdGeorge

 

[emoandy05]

So I wasn't able to get yours to work. But mine is coming along, it does what I need it to do, email-wise. I just cant get it to sent automatically. When trying to fix, the issue I get is "expected end sub".

Any help is appreciated. The code is under Sheet1 object.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim response
    If Target.Address = "$J$10" And Target.Value <> 0 Then
    Call email
    
        Sub email()
            Dim AWorksheet As Worksheet
            Dim Sendrng As Range
            Dim to1 As Range
            Dim subj1 As Range
                
            Set to1 = Worksheets("Sheet1").Range("E2")
         
            Set subj1 = Worksheets("Sheet1").Range("E3")
        
            
            With Application
                .ScreenUpdating = False
                .EnableEvents = False
            End With
        
            Set Sendrng = Worksheets("Sheet1").Range("D8:H18")
        
        
            Set AWorksheet = ActiveSheet
        
            With Sendrng
        
                .Parent.Select
        
                Set Rng = ActiveCell
        
                .Select
        
                ActiveWorkbook.EnvelopeVisible = True
                With .Parent.MailEnvelope
        
                    With .Item
                        .to = to1
                        .Subject = subj1
                        .body = body1
                        .send
                    End With
        
                End With
        
                Rng.Select
            End With
        
            AWorksheet.Select
        
        
            ActiveWorkbook.EnvelopeVisible = False
            
    End If
    End With
End Sub

 

[ColdGeorge]

Hi emoandy05

I use this code, give it a try:

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect([A1], Target) Is Nothing Then
Set olapp = CreateObject("Outlook.application")
Set m = olapp.CreateItem(olMailItem)
    
With m
.To = "anyperson@anmyplace.com"
.CC = ""
.BCC = ""
.Subject = "Any message"
.Body = "Any message"
 
'.Attachments.Add ActiveWorkbook.FullName
'.Display
.Send
End With
      
Set olapp = Nothing
Set m = Nothing
       
End If
End Sub

ColdGeorge

Hi emoandy05

Substitute this:

If Not Intersect([A1], Target) Is Nothing Then

For this:

If Not Application.Intersect(Target.Dependents, Range("A1")) Is Nothing Then

And give it a try again, assuming your formula is at A1.

ColdGeorge