Automatic email when macro is run

[willow1985]

Hello,

I have the below code but I am looking to add something to it. Once the Macro has run but before the message box stating update complete, what I would like it to do is:

go to Sheet "CAPA Log", copy rows A1:P1, paste in an e-mail, then copy the last row with data (A:P) and paste that info in the e-mail as well (headers and last row of data), then automatically e-mail it to a select group of people (person1@email.com, person2@email.com etc) with the subject line: New Capa Added to the Log.
Then finish with the message box, update complete and e-mail sent.

How would I go about modifying the below code to achieve this? I put a large blank area in the code showing where I would like to add it.

Sub Update_CAPA()
'
' Update_CAPA Macro
'
Dim Msg As String, Ans As Variant


Msg = "Would you like to update the CAPA Log with this Data?"


Ans = MsgBox(Msg, vbYesNo)


Select Case Ans


Case vbYes
Sheets("New CAPA").Select
Range("A2:O2").Select
Selection.Copy
Sheets("CAPA Log").Select
Range("CAPA_Log").Cells(1, 1).End(xlDown).Offset(1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("CAPA_Log").Cells(1, 1).End(xlDown).Offset(1).Select
Sheets("New CAPA").Select
Range("B2:O2").Select
Selection.ClearContents
Range("B2").Select
Sheets("Table1").Visible = True
Sheets("Table2").Visible = True
Sheets("Table2").Visible = True
Sheets("Table1").Select
ActiveSheet.PivotTables("PivotTable1").PivotCache.Refresh
Sheets("Table2").Select
ActiveSheet.PivotTables("PivotTable2").PivotCache.Refresh
Sheets("Table3").Select
ActiveSheet.PivotTables("PivotTable3").PivotCache.Refresh
Sheets("Graphs").Select
ActiveSheet.ChartObjects("ADChart").Activate
ActiveChart.PivotLayout.PivotTable.PivotCache.Refresh
ActiveSheet.ChartObjects("StatusChart").Activate
ActiveChart.PivotLayout.PivotTable.PivotCache.Refresh
ActiveSheet.ChartObjects("TypeChart").Activate
ActiveChart.PivotLayout.PivotTable.PivotCache.Refresh
Sheets("Table1").Visible = False
Sheets("Table2").Visible = False
Sheets("Table2").Visible = False
Sheets("New CAPA").Select
Range("B2").Select





Sheets("New CAPA").Select
Range("B2").Select

MsgBox "Update Complete and Email Sent"


Case vbNo
GoTo Quit:
End Select


Quit:

 

[ekrause]

Try adding this to the space in your code:

Set OutlookApp = CreateObject("Outlook.Application")


Set MItem = OutlookApp.CreateItem(0)
With MItem
    .To = "person1@email.com; person2@email.com; etc."
    .Subject = "New CAPA added to the Log"
    .Display
End With


Sheets("CAPA Log").Range(Range("A1").Offset(1), Range("A1").End(xlDown).Offset(-1)).EntireRow.Hidden = True


Sheets("CAPA Log").Range(Range("A1"), Range("A1").End(xlToRight).End(xlDown)).Copy


OutlookApp.ActiveInspector.WordEditor.Application.Selection.Paste


Sheets("CAPA Log").Range(Range("A1"), Range("A1").End(xlDown)).EntireRow.Hidden = False

MItem.Send

This assumes there will be data in all cells in columns A:P to the bottom of your dataset. If there are cells with blank spaces it won't email as expected. But we can adjust that if needed.

Let me know if you need any changes.

 

[willow1985]

This is perfect! Thank you very much!

What I did to avoid the "blank" issue is not allow any data with blanks to update in the log via code:

With ThisWorkbook.Sheets("New CAPA")
If Application.CountIf(.Range("B2:O2"), "") > 0 Then
MsgBox "Please Complete all Fields in Yellow"
Exit Sub
End If
End With
Dim Msg As String, Ans As Variant


Msg = "Would you like to update the CAPA Log with this Data?" etc etc.


Thank you again!

Carla

 

[willow1985]

did some further testing and all is good.

If I have any further questions I will post.

You guys are awesome!