JuicyMusic
Board Regular
- Joined
- Jun 13, 2020
- Messages
- 210
- Office Version
- 365
- Platform
- Windows
Hello,
I found a code in MREXCEL that works very well but I need to tweak it a bit but I am not able to do so.
This code generates an email based on 2 different types of text in column L: "Expiring Soon" and "Expired".
1) This code inserts the text in Column A and puts it in the email body but I would like the data from Column A to F to be inserted, including the header rows.
2) I would like this code to list the rows vertically. One below the other. Example: Row 2 from Column a thru F, then Row 3 from A thru F, and so on.
3) I would like the format in the rows from Column A to F to be inserted as well. Borders and etc. Whatever formatting is there.
4) Is there a way for the email(s) to generate (.Display) as soon as the spreadsheet is open?
Below is the code that I am referring to. I've also uploaded an image of my spreadsheet. I can't wait to see how this code gets adjusted. I am able to adjust some things, but not this time.
Thank you so much in advance. I appreciate your efforts. Juicy,
I found a code in MREXCEL that works very well but I need to tweak it a bit but I am not able to do so.
This code generates an email based on 2 different types of text in column L: "Expiring Soon" and "Expired".
1) This code inserts the text in Column A and puts it in the email body but I would like the data from Column A to F to be inserted, including the header rows.
2) I would like this code to list the rows vertically. One below the other. Example: Row 2 from Column a thru F, then Row 3 from A thru F, and so on.
3) I would like the format in the rows from Column A to F to be inserted as well. Borders and etc. Whatever formatting is there.
4) Is there a way for the email(s) to generate (.Display) as soon as the spreadsheet is open?
Below is the code that I am referring to. I've also uploaded an image of my spreadsheet. I can't wait to see how this code gets adjusted. I am able to adjust some things, but not this time.
Thank you so much in advance. I appreciate your efforts. Juicy,
VBA Code:
Private Sub Workbook_Open()
Dim Instrument1 As String
Dim Instrument2 As String
Dim ws As Worksheet
Dim Status As String
Set ws = Sheets("Renewal 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("L" & i).Value
If Status = "Expiring Soon" Then
Instrument1 = Instrument1 & ws.Range("A" & i).Value & ", "
counter1 = counter1 + 1
End If
If Status = "Expired" Then
Instrument2 = Instrument2 & ws.Range("A" & 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 & " renewal is due soon." & vbNewLine & vbNewLine & _
"Please arrange for review or payment."
On Error Resume Next
With xOutMail
.To = ""
.CC = ""
.BCC = ""
.Subject = "Renewal date is approaching"
.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 & " Registration/Coverage/License has expired." & vbNewLine & vbNewLine & _
"Please arrange for review or payment."
On Error Resume Next
With xOutMail
.To = ""
.CC = ""
.BCC = ""
.Subject = "Warning! Registration/Coverage/License has Expired"
.Body = xMailBody
.Display 'or use .Send
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
End Sub