Automatically send an email out help!

GRIM99

New Member
Joined
Aug 25, 2019
Messages
3
when any cell changes in row C it emails me what was changed and what it is now. Is it possible to see the names as well in row A in the email when any cell is changed in C.. So if C-3 was changed I see the information for A3 and C3 in my email. This is what im using any help be appreciated.

Code:
Option Explicit[/FONT][/COLOR]
[COLOR=#333333][FONT=Verdana][/FONT][/COLOR]
[COLOR=#333333][FONT=Verdana]Dim PrevVal As Variant[/FONT][/COLOR]
[COLOR=#333333][FONT=Verdana]Private Sub Worksheet_Change(ByVal Target As Range)[/FONT][/COLOR]
[COLOR=#333333][FONT=Verdana]If Not Intersect(Target, Range("C:C")) Is Nothing Then[/FONT][/COLOR]
[COLOR=#333333][FONT=Verdana][/FONT][/COLOR]
[COLOR=#333333][FONT=Verdana]    Dim oOL As Object, oMI As Object[/FONT][/COLOR]
[COLOR=#333333][FONT=Verdana]    Set oOL = CreateObject("Outlook.application")[/FONT][/COLOR]
[COLOR=#333333][FONT=Verdana]    Set oMI = oOL.CreateItem(0)[/FONT][/COLOR]
[COLOR=#333333][FONT=Verdana]    With oMI[/FONT][/COLOR]
[COLOR=#333333][FONT=Verdana]        .To = ""[/FONT][/COLOR]
[COLOR=#333333][FONT=Verdana]        .CC = ""[/FONT][/COLOR]
[COLOR=#333333][FONT=Verdana]        .BCC = ""[/FONT][/COLOR]
[COLOR=#333333][FONT=Verdana]        .Subject = "Tier Board change"[/FONT][/COLOR]
[COLOR=#333333][FONT=Verdana]        .body = Environ$("Username") & " Made a change on the Tier Board " & Replace(Split(PrevVal, ",")(0), "$", "") & " @ " & Now & " From tier " & Split(PrevVal, ",")(1) & " to tier " & Range(Split(PrevVal, ",")(0)).Value[/FONT][/COLOR]
[COLOR=#333333][FONT=Verdana]        [/FONT][/COLOR]
[COLOR=#333333][FONT=Verdana]        .Display[/FONT][/COLOR]
[COLOR=#333333][FONT=Verdana]        .send[/FONT][/COLOR]
[COLOR=#333333][FONT=Verdana]    End With[/FONT][/COLOR]
[COLOR=#333333][FONT=Verdana][/FONT][/COLOR]
[COLOR=#333333][FONT=Verdana]End If[/FONT][/COLOR]
[COLOR=#333333][FONT=Verdana]End Sub[/FONT][/COLOR]
[COLOR=#333333][FONT=Verdana][/FONT][/COLOR]
[COLOR=#333333][FONT=Verdana]Private Sub Worksheet_SelectionChange(ByVal Target As Range)[/FONT][/COLOR]
[COLOR=#333333][FONT=Verdana]If Not Intersect(Target, Range("C:C")) Is Nothing Then[/FONT][/COLOR]
[COLOR=#333333][FONT=Verdana]    PrevVal = ActiveCell.Address & "," & ActiveCell.Value[/FONT][/COLOR]
[COLOR=#333333][FONT=Verdana]End If[/FONT][/COLOR]
[COLOR=#333333][FONT=Verdana]End Sub[code][/FONT][/COLOR][/LEFT]
 

Excel Facts

Add Bullets to Range
Select range. Press Ctrl+1. On Number tab, choose Custom. Type Alt+7 then space then @ sign (using 7 on numeric keypad)
Welcome to the forum! Please paste code between code tags. Click # icon on toolbar to insert the tags.

I changed the format a bit. This should give you and idea. It can be done a bit more simply.
Code:
Dim PrevVal As String, PrevR As Range

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim oOL As Object, oMI As Object, r As Range, CurVal
    Set r = Intersect(Target, Columns("C"))
    If r Is Nothing Then Exit Sub
    Set oOL = CreateObject("Outlook.application")
    Set oMI = oOL.CreateItem(0)
    With oMI
        .To = ""
        .cc = ""
        .BCC = ""
        .Subject = "Tier Board change"
        '.Body = Environ$("Username") & " Made a change on the Tier Board " & Replace(Split(PrevVal, ",")(0), "$", "") & " @ " & Now & " From tier " & Split(PrevVal, ",")(1) & " to tier " & Range(Split(PrevVal, ",")(0)).Value
        .Body = Environ$("Username") & " Made a change on the Tier Board @ " & Now & vbCrLf
        .Body = .Body & "From " & PrevR.Address(False, False) & ":" & vbCrLf & PrevVal & vbCrLf
        Union(r.Offset(, -2), r).Copy
        .Body = .Body & "To " & r.Address(False, False) & ":" & vbCrLf & _
            "A" & vbTab & vbTab & "C" & vbCrLf & GetClipboard
        .Display
        '.Send
    End With
    Application.CutCopyMode = False
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim r As Range
    Set r = Intersect(Target, Range("C:C"))
    If r Is Nothing Then Exit Sub
    Set PrevR = r
    r.Copy
    PrevVal = GetClipboard
    Application.CutCopyMode = False
End Sub

Function GetClipboard()
  'Early bound MSForms.DataObject
  'Tools > References > Microsoft Forms 2.0 Object Library
  'Dim MyData As DataObject
  'Set MyData = New DataObject
  
  'Late bound MSForms.DataObject
  Dim MyData As Object
  Set MyData = CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")

  On Error Resume Next
  MyData.GetFromClipboard
  GetClipboard = MyData.GetText
End Function
 
Last edited:
Upvote 0
Thanks for that code one last question The email cam out like this which is great but is it possible to not see the A AND C

[FONT=&quot]jconsentino Made a change onthe Tier Board @ 8/25/2019 3:36:00 PM [/FONT]
[FONT=&quot]From C3: [/FONT]
[FONT=&quot] B [/FONT]<o:p></o:p>
[FONT=&quot]To C3:[/FONT]
[FONT=&quot]A C[/FONT]
[FONT=&quot]Joe Schmoe A[/FONT] <o:p></o:p>
 
Upvote 0
Yes, just delete the concatenation parts out. You can build the body string how you want.

Here is the more simple version.
Code:
Dim PrevVal As String, PrevR As Range

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim oOL As Object, oMI As Object, r As Range, CurVal
    Set r = Intersect(Target, Columns("C"))
    If r Is Nothing Then Exit Sub
    Set oOL = CreateObject("Outlook.application")
    Set oMI = oOL.CreateItem(0)
    With oMI
        .To = ""
        .cc = ""
        .BCC = ""
        .Subject = "Tier Board change"
        .Body = Environ$("Username") & " Made a change on the Tier Board @ " & Now & vbCrLf
        .Body = .Body & "From " & PrevR.Address(False, False) & ":" & vbCrLf & PrevVal & vbCrLf
        .Body = .Body & "To " & r.Address(False, False) & ":" & vbCrLf & _
            r.Offset(, -2) & vbTab & r
        .Display
        '.Send
    End With
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim r As Range
    Set r = Intersect(Target, Range("C:C"))
    If r Is Nothing Then Exit Sub
    Set PrevR = r
    PrevVal = r
End Sub
 
Last edited:
Upvote 0

Forum statistics

Threads
1,213,544
Messages
6,114,239
Members
448,555
Latest member
RobertJones1986

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top