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
Related
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
I have piece of VBA code in an excel workbook that is currently working, but when attempting to add another capability to the VBA, the code returns an error.
Background: On a button click, if Column U contains a value of "Y" an email will be sent with the name of the client (Column W) in the email subject & body. I would like to add in the email address of the account manager (Column V) so that it changes for each email sent.
I understand that Rng is on a procedure-level scope and that it's only visible to notify() so am aiming to define it beforehand and then "calling" it to mymacro(). I've tried to add an additional Sub, but that didn't work.
Have tried using 2 if statements (as below) but don't think this is on the right track either.
I think the issue might be with me incorrectly defining scopes? Or perhaps incorrectly defining "EmailAddr"?
Sub notify()
Dim Rng As Range
Dim EmailAddr As String
For Each Rng In Range("U3:W200")
If (Rng.Value = "Y") Then
mymacro theValue:=Rng.Offset(0, 2).Value
End If
If (Rng.Value = "Y") Then
mymacro EmailAddr = Rng.Offset(0, 1).Value
End If
Next Rng
End Sub
Private Sub mymacro(theValue As String, EmailAddr 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 = "Hi All" & vbNewLine & vbNewLine & _
"This alert has been created via the Compliance Register." & vbNewLine & vbNewLine & _
"Please review the insurance(s) for " & theValue & " that are due to expire in the next 30 days." & vbNewLine & vbNewLine
With xOutMail
.To = "generalmanager#gmail.com;financemanager#gmail.com"
.CC = EmailAddr
.BCC = ""
.Subject = "Insurance(s) for " & theValue & " are expiring soon."
.Body = xMailBody
.Display 'or use .Send
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
End Sub
The code works perfectly if all "EmailAddr" components are removed from both notify() and mymacro() - but, of course, leaves the CC component empty. I'm still a novice at intuitively changing code to suit my needs, so a point in the right direction would be great.
Let me know if I can clarify anything in the meantime.
You only need one loop; change
If (Rng.Value = "Y") Then
mymacro theValue:=Rng.Offset(0, 2).Value
End If
If (Rng.Value = "Y") Then
mymacro EmailAddr = Rng.Offset(0, 1)
End If
to
If (Rng.Value = "Y") Then
mymacro theValue:=Rng.Offset(0, 2).Value, EmailAddr:=Rng.Offset(0, 1)
End If
and remove the Dim EmailAddr As String, since it is a named argument of mymacro, not a local variable.
I continue my work starting from the 1st question here:
Excel VBA - Outlook Email - Body created with rows having a particular value
Now i have another problem.
I want to repeat the below MACROs on all the SHEETS of my file.
In particular, how can I repeat this function on different SHEETS by only clicking in 1 button present in all the sheets?
All the sheets have the same structure.
I mean, the table resulting in the email must be implemented by adding the datas in all the sheets.
The data should be copied starting from the 1st sheet, for ex. TEST(1) to the last sheet, TEST(9).
The email generated after this process must be ONLY one.
Determine the body range
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
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've tried with something like this, but it does not work:
For I = 1 To Worksheets.Count
Sheets(I).Select
***[...]CODE OF "Determine the body range"***
Next I
Sheets("TEST(I)").Select
How can I write an excel macro which will send an automatic e-mail when one of the certain range of cells' value has been changed?
The problem is the range of cells I have chosen has formula which is directly linked to other spreadsheet cells. And those cells' data has been updated by a web connection query of Excel. As shown in the picture below, the a1:b5 range has formula linked to d1:e5 range.
Here is my syntax
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngChangeCells As Range
Dim objOutlookApp As Outlook.Application
Dim objMailItem As Outlook.MailItem
Dim strMailBody As String
On Error Resume Next
Set rngChangeCells = Intersect(Target, Me.Range("a1:b5"))
On Error GoTo 0
If Not rngChangeCells Is Nothing Then
Set objOutlookApp = New Outlook.Application
Set objMailItem = objOutlookApp.CreateItem(olMailItem)
strMailBody = "Cell(s) " & rngChangeCells.Address(False, False) & _
" in the worksheet '" & Me.Name & "' were modified on " & _
Format$(Now, "mm/dd/yyyy") & " at " & Format$(Now, "hh:mm:ss") & _
" by " & Environ$("username") & "."
With objMailItem
.To = "myagmarchuluun#gmail.com"
.Subject = "It has changed"
.Body = strMailBody
.Display
End With
Set rngChangeCells = Nothing
Set objOutlookApp = Nothing
Set objMailItem = Nothing
End If
End Sub
enter image description here
Something like this.
Note: Change YourMacroName to the name of your macro in the code.
If you want the code to work for another cell or more cells you can change the range in the event.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
If Not Application.Intersect(Range("A1"), Target) Is Nothing Then
If IsNumeric(Target.Value) And Target.Value > 200 Then
Call YourMacroName
End If
End If
End Sub
Test this example macro to create/display a Outlook mail with a small text message.
You must copy this macro in a standard module and not in the worksheet module, see this page how.
Note: I use .Display in the code to display the mail, you can change that to .Send
Do not forget to change Call YourMacroName to Call Mail_small_Text_Outlook in the Change event.
Sub Mail_small_Text_Outlook()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Working in Excel 2000-2016
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "Hi there" & vbNewLine & vbNewLine & _
"Cell A1 is changed" & vbNewLine & _
"This is line 2" & vbNewLine & _
"This is line 3" & vbNewLine & _
"This is line 4"
On Error Resume Next
With OutMail
.To = "ron#debruin.nl"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.Body = strbody
'You can add a file like this
'.Attachments.Add ("C:\test.txt")
.Display 'or use .Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
https://www.rondebruin.nl/win/s1/outlook/bmail9.htm
In excel I have the following code which sends out emails for every cell that contains an email address in column K.
This would work except for the header in the table isn't an email address, so it breaks the code. I tried to skip the header by specifying "if cell.value = CONTACT METHOD, which is the header name text, then go to Next cell"
but this causes a "Next without for" error.
Sub Mail_small_Text_Outlook()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Working in Office 2000-2013
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
On Error GoTo cleanup
For Each cell In Columns("K").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "*#*" Then
finaladdress = cell.Value
Else
finaladdress = cell.Value & "#email.smsglobal.com"
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = finaladdress
.Subject = "Reminder"
.Body = "Dear " & Cells(cell.Row, "A").Value _
& vbNewLine & vbNewLine & _
"Please contact us to discuss bringing " & _
"your account up to date"
'You can add files also like this
'.Attachments.Add ("C:\test.txt")
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
If your goal is to skip cell K1 in looping down column K then:
For Each cell In Columns("K2:K" & Rows.Count).Cells.SpecialCells(xlCellTypeConstants)
You can enclose the code within the FOR/EACH loop within a separate IF statement, as below:
Sub Mail_small_Text_Outlook()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Working in Office 2000-2013
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
On Error GoTo cleanup
For Each cell In Columns("K").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value = "CONTACT METHOD" Then
'Do Nothing, or Enter code here
Else
If cell.Value Like "*#*" Then
finaladdress = cell.Value
Else
finaladdress = cell.Value & "#email.smsglobal.com"
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = finaladdress
.Subject = "Reminder"
.Body = "Dear " & Cells(cell.Row, "A").Value _
& vbNewLine & vbNewLine & _
"Please contact us to discuss bringing " & _
"your account up to date"
'You can add files also like this
'.Attachments.Add ("C:\test.txt")
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
End If
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub