Automatically send an email out help!

[GRIM99]

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.

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]

​

 

[Kenneth Hobson]

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.

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

 

[GRIM99]

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></o>
[FONT=&quot]To C3:[/FONT]
[FONT=&quot]A C[/FONT]
[FONT=&quot]Joe Schmoe A[/FONT] <o></o>

 

[Kenneth Hobson]

Yes, just delete the concatenation parts out. You can build the body string how you want.

Here is the more simple version.

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

 

[GRIM99]

Thank you so much !!!!!!!!!