Trying to write code to email information based on one cell, to include other cells values from that same row within the email body. If the Cells(x,11) = Pending, then am wanting to include other information (relative to that cell) in the email body; looking to include the contents of cells -9, and also -7. Thanks so much in advance.
Sub EmailPendings()
Dim xOutApp As Object
Dim xOutMail As Object
Dim xOutMailAttach As String
Dim xMailBody As String
On Error Resume Next
FirstCell = 0
x = 6
While Cells(x, 1).Value <> ""
If Cells(x, 11).Value = "Pending" Then
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
xMailBody = "Hi Team" & vbNewLine & vbNewLine & _
"The following items are pending final approval, and is expected soon. Please proceed with Team assignment." & vbNewLine & vbNewLine & _
"Additional details are included below" & vbNewLine & _
Cells(x, 11).Value = "Pending" _
.FormulaR1C1 = "=(RC[-9],0)" & vbNewLine & _
Range ("C43") & vbNewLine & _
Range("C44") & vbNewLine & _
Range("C45") & vbNewLine & _
"Best,"
On Error Resume Next
With xOutMail
.To = ""
.CC = ""
.BCC = ""
.Subject = "Assignments Needed From Team Review: " & Date
.Body = xMailBody
.Display 'or use .Send
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
exitHandler:
Exit Sub
errHandler:
MsgBox "Could not create email"
Resume exitHandler
End If
'Go to next line
x = x + 1
Wend
Related
I am new to macros and I cant seem to find an answer to my problem. I have created a couple macros which work perfectly except for one issue. When I first open my excel sheet I have to step into my macro and "reset" it then it will work fine until I save, close and reopen the sheet the next time.
When I step into it the first line of it is highlighted yellow with an arrow to the left of it indicating an error but I'm not sure what the error is or how to pull up the error msg.
The line highlighted yellow is "Sub DueDateReminder()"
Private Sub Worksheet_calculate()
Call DueDateReminder
End Sub
Sub DueDateReminder()
Dim c As Range
For Each c In Range("K19:K500")
If c.Value = "No" Then
c.Value = "Yes"
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
xMailBody = "Hello " & c.Offset(0, 4) & vbNewLine & vbNewLine & _
"This in automatic message to inform you that you have an upcoming due date regarding " & c.Offset(0, -3).Text & " on " & c.Offset(0, -1) & vbNewLine & vbNewLine & _
"Best Regards!"
On Error Resume Next
With xOutMail
.To = c.Offset(0, 3)
.CC = ""
.BCC = ""
.Subject = "Project Review Meeting Due Date"
.Body = xMailBody
.Attachments.Add
.display ' use .send for automatic email
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
End If
Next c
End Sub
I need to send and email based on the expiry date of different machines.
I want to include all the expired machines in one email, as opposed to multiple emails.
The Excel sheet includes expiration date in column "I", the name of the machine in column "B", and has a function that calculates if my machines are "calibrated", "expired", or "near expiration", in column "P".
Private Sub Workbook_Open()
Dim Instrument As String
Dim Status As String
Status = Range("P6").Value
If IsNull(Status) = True Then Exit Sub
If Status = "Expiring Soon" Then
Instrument = Range("B6").Value
Mail_Expiring_Soon_Outlook Instrument
End If
If Status = "Expired" Then
Instrument = Range("B6").Value
Mail_Expired_Outlook Instrument
End If
End Sub
Sub Mail_Expiring_Soon_Outlook(Instrument As String)
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
xMailBody = "Attention" & vbNewLine & vbNewLine & _
"The " & Instrument & " calibration is due within 30 days." & vbNewLine & vbNewLine & _
"Please arrange calibration."
On Error Resume Next
With xOutMail
.To = ""
.CC = ""
.BCC = ""
.Subject = "Calibration Due within 30 days"
.Body = xMailBody
.Display
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
End Sub
Sub Mail_Expired_Outlook(Instrument As String)
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
xMailBody = "Warning!" & vbNewLine & vbNewLine & _
"The " & Instrument & " calibration is expired." & vbNewLine & vbNewLine & _
"Please arrange calibration."
On Error Resume Next
With xOutMail
.To = ""
.CC = ""
.BCC = ""
.Subject = "Warning! Calibration is Expired"
.Body = xMailBody
.Display
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
End Sub
If I've understood what you're aiming for, you could simply loop through all the rows adding machine names to one of two variables depending on the status.
You could use something like the following...
Private Sub Workbook_Open()
Dim ExpiringSoon As String
Dim Expired As String
Dim Subject As String
Dim Body As String
Dim Row As Long
' Loop through rows, from row 2 until the last used row in column B
For Row = 2 To Cells(Rows.Count, "B").End(xlUp).Row
Select Case Cells(Row, "P")
Case "Expiring Soon"
ExpiringSoon = ExpiringSoon & Cells(Row, "B") & vbNewLine
Case "Expired"
Expired = Expired & Cells(Row, "B") & vbNewLine
End Select
Next
If ExpiringSoon <> "" Then
Subject = "Calibration Due within 30 days"
Body = "Attention" & vbNewLine & vbNewLine & _
"Calibration is due within 30 days for the following machines:" & vbNewLine & _
ExpiringSoon & vbNewLine & _
"Please arrange calibration."
Send_Mail Subject, Body
End If
If Expired <> "" Then
Subject = "Warning! Calibration is Expired"
Body = "Warning!" & vbNewLine & vbNewLine & _
"Calibration is expired for the following machines:" & vbNewLine & _
Expired & vbNewLine & _
"Please arrange calibration."
Send_Mail Subject, Body
End If
End Sub
Sub Send_Mail(Subject As String, Body As String)
On Error Resume Next
With CreateObject("Outlook.Application").CreateItem(0)
.Subject = Subject
.BodyFormat = 1
.Body = Body
.Display
End With
End Sub
Private Sub Workbook_Open()
Dim Instrument1 As String
Dim Instrument2 As String
Dim ws As Worksheet
Dim Status As String
Set ws = Sheets("DAQ Fault Log")
lr = ws.Range("A" & Rows.Count).End(xlUp).Row
' MsgBox "This code ran at Excel start!"
' On Error Resume Next
' If Target.Cells.Count > 1 Then Exit Sub
counter1 = 0
counter2 = 0
On Error Resume Next
For i = 2 To lr
Status = ws.Range("P" & i).Value
If Status = "Expiring Soon" Then
Instrument1 = Instrument1 & ws.Range("B" & i).Value & ", "
counter1 = counter1 + 1
End If
If Status = "Expired" Then
Instrument2 = Instrument2 & ws.Range("B" & i).Value & ", "
counter2 = counter2 + 1
End If
Next i
If counter1 > 0 And counter1 = 1 Then Mail_Expiring_Soon_Outlook Left(Instrument1, Len(Instrument1) - 2)
If counter1 > 0 And counter1 > 1 Then Mail_Expiring_Soon_Outlook Left(Instrument1, Len(Instrument1) - 1)
If counter2 > 0 And counter2 = 1 Then Mail_Expired_Outlook Left(Instrument2, Len(Instrument2) - 2)
If counter2 > 0 And counter2 > 1 Then Mail_Expired_Outlook Left(Instrument2, Len(Instrument2) - 1)
End Sub
Sub Mail_Expiring_Soon_Outlook(Instrument1 As String)
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
xMailBody = "Attention" & vbNewLine & vbNewLine & _
"The " & Instrument1 & " calibration is due within 30 days." & vbNewLine & vbNewLine & _
"Please arrange calibration."
On Error Resume Next
With xOutMail
.to = ""
.CC = ""
.BCC = ""
.Subject = "Calibration Due within 30 days"
.Body = xMailBody
.Display 'or use .Send
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
End Sub
Sub Mail_Expired_Outlook(Instrument2 As String)
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
xMailBody = "Warning!" & vbNewLine & vbNewLine & _
"The " & Instrument2 & " calibration is expired." & vbNewLine & vbNewLine & _
"Please arrange calibration."
On Error Resume Next
With xOutMail
.to = ""
.CC = ""
.BCC = ""
.Subject = "Warning! Calibration is Expired"
.Body = xMailBody
.Display 'or use .Send
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
End Sub
I've used an example to create code to send emails from Excel (with Outlook), using a "Button" (red in my file).
The code works. There is a pre-selected range of rows [B1:K20], that can be manually modified thanks to the Application.InputBox function.
Sub MAIL()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim StrBodyIn, StrBodyEnd As String
StrBodyIn = "Bonjour," & "<br>" & _
" " & "<br>" & _
"Buongiorno," & "<br>"
StrBodyEnd = " " & "<br>" & _
"Cordialement" & "<br>" & _
" " & "<br>" & _
Range("M2") & "<br>"
Set rng = Nothing
On Error Resume Next
Set rng = Sheets("TEST").Application.InputBox("Range", xTitleId, "B1:K20", Type:=8)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "ATTENZIONE!!!" & _
vbNewLine & "Seleziona un range di celle valido.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "email#gmail.com"
.CC = ""
.BCC = ""
.Subject = "SITUATION"
.HTMLBody = "<p style='font-family:calibri;font-size:16'>" & StrBodyIn & RangetoHTML(rng) & "<p style='font-family:calibri;font-size:16'>" & StrBodyEnd
.Display 'or use .Send
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
I want to add a condition.
The selected range of rows should be copied to the body of the email if the "X" symbol is written in the column "A".
In my example, rows n° 1, 2 and n° 5 should be copied.
The two tasks here are separate so I would code them as such. Here would be my approach. Separate your sub into two logical procedures.
Determine the body range
Send the email with the range
Determine the body range
Link your button to this macro. The macro will take an input and convert it into a single column range (Column B). We will then loop through the selected range and look at Column A to determine if there is an x or not. If an x is present, we will resize the range back to it's original size and add it to a collection of cells (Final).
Once the loop is complete, the macro will then do one of the following:
If the range is empty, it will prompt your message box and end the sub (your email macro is never initiated)
If the range is not empty, we will call your EMAIL macro and pass the range along to it.
Sub EmailRange()
Dim Initial As Range, Final As Range, nCell As Range
On Error Resume Next
Set Initial = Sheets("TEST").Application.InputBox("Range", xTitleId, "B1:K20", Type:=8)
On Error GoTo 0
For Each nCell In Initial.Resize(Initial.Rows.Count, 1)
If nCell.Offset(, -1) = "X" Then
If Not Final Is Nothing Then
Set Final = Union(Final, nCell.Resize(1, Initial.Columns.Count))
Else
Set Final = nCell.Resize(1, Initial.Columns.Count)
End If
End If
Next nCell
If Not Final Is Nothing Then
MAIL Final
Else
MsgBox "ATTENZIONE!!!" & vbNewLine & "Seleziona un range di celle valido.", vbOKOnly
End If
End Sub
Send the email with the range
Notice that the macro now has an input (On first line). If the sub is called, you no longer need to validate anything since this was all done in the original sub!
Sub MAIL(Final as Range)
Dim OutApp As Object, OutMail As Object
Dim StrBodyIn As String, StrBodyEnd As String
StrBodyIn = "Bonjour," & "<br>" & " " & "<br>" & "Buongiorno," & "<br>"
StrBodyEnd = " " & "<br>" & "Cordialement" & "<br>" & " " & "<br>" & Range("M2") & "<br>"
Application.EnableEvents = False
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "email#gmail.com"
.CC = ""
.BCC = ""
.Subject = "SITUATION"
.HTMLBody = "<p style='font-family:calibri;font-size:16'>" & StrBodyIn & RangetoHTML(Final) & "<p style='font-family:calibri;font-size:16'>" & StrBodyEnd
.Display 'or use .Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
I am using below code to send email from excel when user press the button. it works fine. i actually want to fine tune this because right now what is happening is when in Column C there is a duplicate email and in column N it is all yes separate emails are generated. what i want to do is if there is a duplicate email in column C one email should be generated with subject and body from the duplicate rows
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
'On Error Resume Next
LastRow = Range("C" & Rows.Count).End(xlUp).Row
For Each Cell In Range("C8:C" & LastRow)
If WorksheetFunction.CountIf(Range("C8:C" & Cell.Row), Cell) = 1 Then
If Cells(Cell.Row, 14) = "Yes" Then
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
xMailBody = "Dear " & Cells(Cell.Row, 2) & vbNewLine & vbNewLine & _
Cells(Cell.Row, 7) & " " & Cells(Cell.Row, 6) & vbNewLine & _
"were issue to you for project " & Cells(Cell.Row, 8) & vbNewLine & vbNewLine & vbNewLine & vbNewLine & _
"This is a system generated email and doesn't require signature"
On Error Resume Next
With xOutMail
.To = Cells(Cell.Row, 3)
.CC = Cells(Cell.Row, 5)
.BCC = ""
.Subject = Cells(Cell.Row, 7) & " " & Cells(Cell.Row, 6) & " Issued to " & Cells(Cell.Row, 4)
.Body = xMailBody
'.Attachments.Add ActiveWorkbook.FullName
.Display
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
End If
End If
Next Cell
You can try:
Option Explicit
Public Sub Get_Unique_Count_Paste_Array()
Dim Ob As Object
Dim rng As Range
Dim LR As Long
Dim str As String
With Worksheets("Sheet1")
LR = .Range("C" & Rows.Count).End(xlUp).Row
Set Ob = CreateObject("scripting.dictionary")
For Each rng In .Range("C8:C" & LR)
str = Trim(rng.Value)
If Len(str) > 0 Then
Ob(str) = Ob(str) + 1
If Ob(str) = 1 Then '<= Check how many times email address appears in the array & if it s appears only one time then..
MsgBox str '<= Insert your code here
End If
End If
Next rng
End With
End Sub
I have a slight issue with a macro. It works fine at the moment, but I need to add some code to do the following but don't know at what point to add it:
If for each cell in Column C that there is a blank cell to look for the email address on the same row but 10 columns over to the right in Column M
In the start of the body "Hi There (Column B content)
In the body of the email I would like for the macro to insert the contents from column F like this: "Please choose the following option (Column F content)
Any Ideas on how I can modify the code to include these options please.
Thank you for your time.
Sub Send_Email()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim cel As Range
Dim SigString As String
Dim Signature As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
SigString = Environ("appdata") & _
"\Microsoft\Signatures\GBS.txt"
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If
For Each cel In Range(("C2"), Range("C2").End(xlDown))
strbody = "Hi there" & vbNewLine & vbNewLine & _
"My name Is William, Please choose the following option ..." & vbNewLine & _
"I work at Fair" & vbNewLine & _
"Bye" & vbNewLine & _
"WH"
On Error Resume Next
With OutMail
.To = cel.Value
.CC = cel.Offset(0, 10).Value
'.BCC = ""
.Subject = "Choose you plan"
.Body = strbody & vbNewLine & vbNewLine & Signature
.Display
'.Attachments.Add ("C:\test.txt")
'.Send
End With
On Error GoTo 0
Next cel
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Try this one:
Sub Send_Email()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim cel As Range
Dim SigString As String
Dim Signature As String
Dim lastrow As Long
Set OutApp = CreateObject("Outlook.Application")
SigString = Environ("appdata") & _
"\Microsoft\Signatures\GBS.txt"
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If
lastrow = Cells(Rows.Count, 3).End(xlUp).Row
For Each cel In Range("C2:C" & lastrow)
strbody = "Hi there" & cel.Offset(, -1) & vbNewLine & vbNewLine & _
"My name Is William, Please choose the following option ..." & vbNewLine & _
cel.Offset(, 3) & _
"I work at Fair" & vbNewLine & _
"Bye" & vbNewLine & _
"WH"
On Error Resume Next
With OutApp.CreateItem(0)
If cel.Value <> "" Then
.To = cel.Value
.CC = cel.Offset(0, 10).Value
Else
.To = cel.Offset(0, 10).Value & ", " & Join(Application.Index(cel.Offset(, -2).Resize(, 4).Value, 0), ", ")
End If
'.BCC = ""
.Subject = "Choose you plan"
.Body = strbody & vbNewLine & vbNewLine & Signature
.Display
'.Attachments.Add ("C:\test.txt")
'.Send
End With
On Error GoTo 0
Next cel
Set OutApp = Nothing
End Sub