Ending macro in Excel - excel

So, I was helped with this code from Ron de Bruin from user Vityata but I am having trouble getting the macro to STOP running once it runs out of WO's and emails. If I put ' stop ' in after .send I have to click run over and over until all the emails are sent and everything is marked as 'sent', and then on the last one it won't stop running until I hit escape. I want to find a way to make the code stop running once there are no more work orders (paired with emails that haven't been sent yet) left to email out. If there is a way to also note the read receipt in a column of the 2018 worksheet that would be extremely helpful but I've been struggling. I am used to creating forms in VBA, so information going OUT has always been difficult for me to automate.
The original post is here Original post
Sub test2()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
For Each cell In Worksheets("2018").Columns("T").Cells
Set OutMail = OutApp.CreateItem(0)
If cell.Value Like "?*#?*.?*" Then 'try with less conditions first
With OutMail
.To = Cells(cell.Row, "T").Value
.Subject = "Work Order: " & Cells(cell.Row, "G").Value & " assigned"
.Body = "Work Order: " & Cells(cell.Row, "G").Value & _
" has been assigned to you." & _
vbNewLine & vbNewLine & _
"Region: " & Cells(cell.Row, "B").Value & vbNewLine & _
"District: " & Cells(cell.Row, "C").Value & vbNewLine & _
"City: " & Cells(cell.Row, "D").Value & vbNewLine & _
"Atlas: " & Cells(cell.Row, "E").Value & vbNewLine & _
"Notification Number: " & Cells(cell.Row, "F").Value & vbNewLine
.ReadReceiptRequested = True
.OriginatorDeliveryReportRequested = True
.Send
End With
Cells(cell.Row, "V").Value = "sent"
Set OutMail = Nothing
End If
Next cell
'Set OutApp = Nothing 'it will be Nothing after End Sub
Application.ScreenUpdating = True
End Sub
EDIT:
I tried to use the Do Loop function with no luck

The issue is that you run through all cells in column T, because the range Worksheets("2018").Columns("T").Cells contains the complete column.
Add the following code at the beginning of your sub
Dim lastRow As Long
Dim ws As Worksheet
Dim rg As Range
Set ws = Worksheets("2018")
With ws
lastRow = .Cells(Rows.Count, "T").End(xlUp).Row
Set rg = Range(.Cells(1, "T"), .Cells(lastRow, "T"))
End With
And change the for loop to
For Each cell In rg
rg only contains the filled cells of column T. In this way the code only runs through the cells which contain data.
PS Based on the information in the comment you would need to code your condition like that
If cell.Value Like "?*#?*.?*" And UCASE(cell.Offset(0, 1).Value) <> "SENT" Then

Related

Pull Data By Vendor from Excel for Outlook Email

I have a list of vendors that I sort by name and then have a macro go through and pull out data pieces from fields and place them inside an Outlook email. Pretty straightforward until I get to vendors with multiple lines, as I then need to have the code know to look at all the lines for that vendor and pull their info and place it into a list in the email (so they do not get multiple emails all at once).
The above image is a sample of the list after I have sorted it by vendor. So I would want one email for each vendor, but vendor1 would need the data from Invoice, Paid Amt, Check ID, and Check Dt for both of his lines. Vendor 2 would just have one line, and Vendor3 would have 3. I need a way to have the macro know to look at the vendor name (or Vendor #) and know that it needs to pull the data from the next line and include it in that same email until it is at the next vendor.
I am not a programmer and am trying to make this work. Below is an example of what I have been trying so far but it only creates one email for every line. Hoping someone smarter than me can help me. Thanks.
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim strDir As String
Dim strFilename As String
Dim sigString As String
Dim strbody As String
Dim strname As String
Dim strName1 As String
Dim strDept As String
Dim strName2 As String
Dim lr As Long
Dim oItem As Object
Dim dteSat As Date
Dim nextSat As Date
Dim lastRow As Long
Dim ws As String
'Link to Outlook, use GetBoiler function to pull email signature
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
sigString = Environ("appdata") & _
"\Microsoft\Signatures\Uncashed Checks.htm"
If Dir(sigString) <> "" Then
signature = GetBoiler(sigString)
Else
signature = ""
End If
Select Case Time
Case 0.25 To 0.5
GreetTime = "Good morning"
Case 0.5 To 0.71
GreetTime = "Good afternoon"
Case Else
GreetTime = "Good evening"
End Select
'Define the date for the next Saturday
With Item
K = Weekday(TODAY)
dteChk = Weekday(TODAY) - 30
dteSat = Now() + (10 - K)
nextSat = Date + 7 - Weekday(Date, vfSaturday)
End With
'Select the currently active sheet and insert a column next to column I, then fill it with the word 'yes'. The yes values will act as triggers to tell the code to run for that row.
'Delete first 7 rows of report. Find the Paid Amt header and then replace that column with a re-formatted one that shows the full numbers with decimals and zeroes. Change column E
'to UPPER case using the index and upper functions.
lr = ActiveSheet.UsedRange.Rows.Count
lastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
Rows("1:7").Select
Columns("C").SpecialCells(xlBlanks).EntireRow.Delete
Columns("I:I").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Set rng8 = Range("A1:Z1").Find("Paid Amt")
Set rng9 = ActiveSheet.Range(rng8, ActiveSheet.Cells(Rows.Count, rng8.Column).End(xlUp).Address)
rng9.Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
ActiveCell.FormulaR1C1 = "=TEXT(RC[+1],""#.00"")"
ActiveCell.Copy
Range(ActiveCell.Offset(350 - ActiveCell.Row, 0), ActiveCell.Offset(1, 0)).Select
ActiveSheet.Paste
ActiveCell.Offset.Resize(1).EntireColumn.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveCell.Offset(0, 1).Select
ActiveCell.Offset.Resize(1).EntireColumn.Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToRight
Range("i2") = "Yes"
Range("I2").AutoFill Destination:=Range("I2:I" & lr)
[e2:e350] = [INDEX(UPPER(e2:e350),)]
'Begin a loop that looks at all the yes values in column I and then begins to create emails. Define the columns to be used for data by looking for the header names such as Paid Amt.
For Each cell In Columns("G").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*#?*.?*" And _
LCase(Cells(cell.Row, "I").Value) = "yes" Then
Set OutMail = OutApp.CreateItem(0)
Set rng8 = Range("A1:Z1").Find("Paid Amt")
Set foundCell = Cells(cell.Row, rng8.Column)
Set rng9 = Range("A1:AG1").Find("Check Dt")
Set foundCell1 = Cells(cell.Row, rng9.Column)
Set rng12 = Range("A1:AG1").Find("Student Perm Address")
Set foundcell2 = Cells(cell.Row, rng12.Column)
'Create the actual email data, definiing the body and recipients/names, etc, based on the values in the cells noted below. Sentonbehalf is the 'From' field. Change font color
'using the hexadecimal codes. The one used here 1F497D is Blue-Gray.
With OutMail
strname = Cells(cell.Row, "A").Value
strName2 = Trim(Split(strname, ",")(1))
strName3 = Cells(cell.Row, "R").Value
strName4 = Cells(cell.Row, "E").Value
strbody = "<Font face = TimesNewRoman p style=font-size:18.5px color = #0033CC)<br><br>You are receiving this email because you have an uncashed check that was sent to you over 30 days ago. " & _
"Please cash or deposit your check.<br><br>" & _
"<B>The amount of the check is $" & foundCell & " and is dated " & foundCell1 & ". The check was mailed to the following address: <br><br>" & _
"<ul>" & foundcell2 & "<br></B></ul>"
.SentOnBehalfOfName = "accounts-payable#salemstate.edu"
.To = cell.Value
.Subject = "Uncashed Check from Salem State University"
.HTMLBody = "<Font face = TimesNewRoman p style=font-size:26.5px color = #0033CC><B>" & "Important Information Regarding Your Student Account </B><br><br><p style=font-size:18.5px> Dear " & strName2 & ", " & strbody & "<br>" & signature & "<HTML><BODY><IMG src='C:\Users\gmorris\Pictures\Saved Pictures\220px-Salem_State_University_logo.png' /></BODY></HTML>"
.display 'Or use Send
End With
Set OutMail = Nothing
End If
Next cell
End Sub
If the email addresses are sorted:
When the email address matches the previous:
Bypass creating email, append to the body.
When there is a new email address:
Send the existing mail before creating new email.
Option Explicit
Sub oneEmail_SortedEmailAddresses()
Dim OutApp As Object
Dim OutMail As Object
Dim strVoucher As String
Dim lr As Long
Set OutApp = CreateObject("Outlook.Application")
lr = ActiveSheet.UsedRange.Rows.Count
Dim toAddress As String
Dim i As Long
Dim refundDescYes As Boolean
For i = 2 To lr
' Email address
If ActiveSheet.Range("N" & i).Value <> "" Then
' One email per email address
' This assumes the addresses are sorted
If ActiveSheet.Range("N" & i).Value <> toAddress Then
If Not OutMail Is Nothing Then
If refundDescYes = True Then
OutMail.display
Else
OutMail.Close 1 ' olDiscard
End If
End If
toAddress = ActiveSheet.Range("N" & i).Value
Debug.Print toAddress
Set OutMail = Nothing
refundDescYes = False
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = toAddress
.Subject = "Uncashed Check from Salem State University"
End With
End If
' Refund Desc
If ActiveSheet.Range("I" & i).Value = "Yes" Then
refundDescYes = True
' Voucher
strVoucher = Cells(i, "D").Value
With OutMail
.HTMLBody = .HTMLBody & "<br>" & strVoucher & "<br>"
End With
End If
End If
Next
If Not OutMail Is Nothing Then
If refundDescYes = True Then
OutMail.display
Else
OutMail.Close 1 ' olDiscard
End If
End If
Set OutMail = Nothing
Debug.Print "Done."
End Sub

Excel VBA - How to run the same macro at the same time on all the sheets - generating one email

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

Change loop from every cell to particular range in Excel VBA

I have the following piece of code which sends emails in bulk.
Sub Sengrd_Files()
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range
para2 = ""
para3 = ""
para232 = Range("AA2").Value
With Application
.EnableEvents = False
.ScreenUpdating = True
End With
Set sh = Sheets("Sheet1")
Set OutApp = CreateObject("Outlook.Application")
For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
'Enter the path/file names in the C:Z column in each row
Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")
If cell.Value Like "?*#?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = cell.Value
.Subject = "Circle Profitability Report for the period ended 30-NOV-2017"
.Body = "Dear Sir/Madam," _
& vbNewLine _
& para232 & vbNewLine _
& vbNewLine & para2 & vbNewLine _
& Remark & vbNewLine & vbNewLine _
& para3 & vbNewLine & vbNewLine
For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
.Send 'Or use .Display
End With
Set OutMail = Nothing
End If
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
7 different mails will be sent to different people mentioned in Column B with Attachment defined in Col C.
The Macro by default sends mails for ALL line items probably because of this line in code
**For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)**
I cannot define a variable i and change the above line to
**For Each i =1 to 5 sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)**
due to syntax error. Can anyone help me in syntax in replacing "For each cell in" to a finite range.
This is how to make the bulk-mail-sender send only to a given range (in this case B2 - B5):
For Each cell In sh.Range("B2:B5")
And do not forget - spam is bad.

Making unambiguous concatenate when retrieving info for email

The aim is to check individual worksheets for a list of dates in a range, and then send an email listing these dates to an email address located in the sheet.
The current code concatenates the dates in the current sheet as well as the dates on the previous sheet, instead of just the dates found on this sheet.
I'm struggling to make it uni-vocal, tried putting "ws." before each aCell instruction but get compile error.
Sub Mail_Outlook()
Dim ws As Worksheet
Dim wsName As Variant
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim strbody As String
Dim string1 As String
Dim aCell As Range
Dim i As Integer
i = 0
For Each wsName In Array("sheet1", "sheet2", "sheet3")
Set ws = Worksheets(wsName)
'retrieve all missing dates
For Each aCell In ws.Range("Aa1:Aa1000")
If aCell.Value <> "" Then
i = i + 1
If i <> 1 Then
string1 = string1 & ", " & aCell.Value
Else
string1 = aCell.Value
End If
End If
Next
'send email
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "Good day " & ws.Range("E3").Cells & vbNewLine & vbNewLine & _
"" & vbNewLine & vbNewLine & _
"" & vbNewLine & vbNewLine & _
string1 & vbNewLine & vbNewLine & vbNewLine & vbNewLine & _
"(This is an automated message)" & vbNewLine & vbNewLine & _
"Best regards" & vbNewLine & vbNewLine & _
On Error Resume Next
With OutMail
.To = ws.Range("E5").Text
.CC = ""
.BCC = ""
.Subject = ""
.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
Next
End Sub
From the OP's comments:
code as is produces no errors, but e.g. the second email contains the string for the first sheet and second sheet, rather than just the second sheet.
Zero the string before going into the second iteration of the loop.
For Each wsName In Array("sheet1", "sheet2", "sheet3")
Set ws = Worksheets(wsName)
string1 = vbNullString 'reset string1 to a zero-length string for each ws
'retrieve all missing dates
For Each aCell In ws.Range("Aa1:Aa1000")
'all the rest of the concatenation code
next aCell
'all the rest of the email code
Next wsName

Macro send notification when release date is not valid anymore

Next is some macro which compare cell D with current date and if it is in past it send notification to email defined in cell L. The problem here is that the macro need to be run manually by pressing Alt+F8, so the question is how to make the macro automatically run when it noticed that updated cell D value is in past, so there is no need all the time to run the macro manually.
Thanks in advance
Sub SendMail()
Dim OutApp As Object
Dim OutMail As Object
Dim RelDate As Range
Dim lastRow As Long
Dim dateCell, dateCell1 As Date
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
lastRow = Range("A" & Rows.Count).End(xlUp).Row
On Error GoTo cleanup
For Each RelDate In Range("D2:D" & lastRow)
If RelDate = "" Then GoTo 1
dateCell = RelDate.Value
dateCell1 = Cells(RelDate.Row, "C").Value
If dateCell < Date Then ' this if cell value is smalle than today then it will send notification
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = Cells(RelDate.Row, "L").Value
.Subject = "Release Date Changed" ' Change your massage subject here
'Change body of the massage here
.Body = "Dear " & Cells(RelDate.Row, "E").Value _
& vbNewLine & vbNewLine & _
"The release date of " & Cells(RelDate.Row, "A").Value & _
" is changed to " & dateCell _
& vbNewLine & vbNewLine _
& vbNewLine & vbNewLine & _
"Regards," & vbNewLine & _
"Your Name"
.send
End With
On Error GoTo 0
Set OutMail = Nothing
End If
' Cells(RelDate.Row, "C").Value = dateCell
' RelDate.ClearContents
1: Next RelDate
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
Use this code in worksheet_change event. It will compare the date in all the changed cells in column "D" and if condition is true, it will call the sendmail procedure. Please adjust your sendmail code accordingly.
This code also works if you copy paste multiple rows of data.
Hope that help!. :-)
Private Sub Worksheet_Change(ByVal Target As Range)
Dim to_email As String
Dim subject As String
Dim body As String
For Each cell In Target.Cells
On Error Resume Next
If cell.Column = 4 And cell < Date Then
On Error GoTo errhandler
to_email = ActiveSheet.Cells(cell.Row, "L").Value
subject = "Release Date Changed"
body = "Dear " & ActiveSheet.Cells(cell.Row, "E").Value _
& vbNewLine & vbNewLine & _
"The release date of " & ActiveSheet.Cells(cell.Row, "A").Value & _
" is changed to " & ActiveSheet.Cells(cell.Row, 4) _
& vbNewLine & vbNewLine _
& vbNewLine & vbNewLine & _
"Regards," & vbNewLine & _
"Your Name"
sendmail to_email, subject, body
End If
Next cell
Exit Sub
errhandler:
Err.Raise Err.Number, Err.Source, Err.Description
End Sub
Sub sendmail(to_email As String, subject As String, body As String)
adjust your code accordingly
End Sub

Resources