How to assign Thisworkbook macro to Form control - excel

I have a workbook to send out email reminders based on the due date. I would like to change it such that the macro will run when I click a button instead of running automatically when it is opened.
ThisWorkbook:
Sub Workbook_Open()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If ws.Cells(1, 1).Value = "Feedback Report (FR) Log" Then CheckDates ws:=ws
Next ws
End Sub
Module1:
Option Explicit
Dim Bcell As Range
Dim iTo, iSubject, iBody As String
Dim ImportanceLevel As String
Public Sub CheckDates(ws As Worksheet)
For Each Bcell In Range("a4", Range("a" & Rows.Count).End(xlUp))
' if email column is not empty then command continues
If Bcell.Offset(0, 15) <> Empty Then
' mail will not be sent if current time is within 23.7 hours
' from time of mail last sent.
If Now() - Bcell.Offset(0, 49) > 0.9875 Then
If Bcell.Offset(0, 25) = Empty Then
If DateDiff("d", Now(), Bcell.Offset(0, 13)) = 7 Then
iTo = Bcell.Offset(0, 15)
iSubject = Bcell & " Due"
iBody = "<font face=""Calibri"" size=""3"">" & "Dear all,<br/><br/>" & _
"<u>FR No. " & Bcell & "</u><br/><br/>" & "Please be reminded that " & Bcell & " will be due by <b><FONT COLOR=#ff0000>" & _
Bcell.Offset(0, 13) & "</font></b>." & _
" Kindly ensure that the FR is closed by the due date and provide the draft FR report with preliminary investigation (Section B & D filled) to Quality.<br/><br/>" _
& "Thank you<br/><br/>" & "Best Regards,<br/>" & "Quality Department<br/><br/>" _
& "company Pte Ltd.<br/>" & "</font>"
SendEmail
Bcell.Offset(0, 49) = Now()
End If
End If
End If
End If
iTo = Empty
iSubject = Empty
iBody = Empty
Next Bcell
End Sub
Private Sub SendEmail()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = iTo
.CC = "email#email.com"
.BCC = ""
.Subject = iSubject
.HTMLBody = iBody
.Importance = ImportanceLevel
'You can add a file like this
'.Attachments.Add ("C:\test.txt")
.send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub

You have two ways to accomplish this depending on the type of button you want to use to run the macro:
a) If the button is a simply Shape (Insert > Shapes), you need to move the contents of Workbook_Open to a new sub within your Module1 (let's call it "trigger") and right-click the shape > Assign macro > "trigger".
Sub trigger()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If ws.Cells(1, 1).Value = "Feedback Report (FR) Log" Then CheckDates ws:=ws
End If
Next ws
End Sub
b) If the button is not a shape but a form button, you need to double-click it while on the design view and move the contents of "trigger" to its own click sub (CommandButton1_click()).
c) Finally, remember to remove the contents of Workbook_Open() sub.

Related

How to create several individual emails from Excel sheets?

I want to grab data from specified worksheets in an Excel workbook and then generate individual emails from each individual sheet.
Right now, the code will generate the first email from the first sheet then cycle through the remaining tabs without creating additional emails. I can confirm that the code is progressing beyond the first sheet via a MsgBox ActiveSheet.Name check.
I am leveraging Ron DeBruin's RangetoHtml function in a separate module.
Sub ClientEvent_Email_Generation()
Dim OutApp As Object
Dim OutMail As Object
Dim count_row, count_col As Integer
Dim Event_Table_Data As Range
Dim Event2_Table_Data As Range
Dim strl As String, STR2 As String, STR3 As String
Dim WS As Worksheet
Dim I As Integer
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
For Each WS In ThisWorkbook.Sheets
WS.Activate
If WS.Name <> "DATA INPUT" And WS.Name <> "FORMATTED DATA TABLE" And WS.Name <> "REP CODE MAPPING TABLE" And WS.Name <> "IDEAS TAB" And WS.Name <> "REFERENCE" Then
count_row = WorksheetFunction.CountA(WS.Range("A10", Range("a10").End(xlDown)))
count_col = WorksheetFunction.CountA(WS.Range("A10", Range("a10").End(xlToRight)))
Set Event_Table_Data = WS.Cells.Range(Cells(9, 1), Cells(count_row, count_col))
Set Event2_Table_Data = Sheets("w61").Range(Cells(9, 1), Cells(count_row, count_col))
str1 = "<BODY style=font-size:12pt;font-family:Times New Roman>" & _
"Hello " & Range("L3").Value & ",<br><br>The following account(s) listed below appear to have an upcoming event(s)<br>"
STR2 = "<br> Included are suggestions for an activity which may fit your client's needs.<br>"
STR3 = "<br> You may place an order, or contact us for alternate ideas if these don't fit your client."
On Error Resume Next
With OutMail
.To = WS.Range("l4").Value
.cc = ""
.bcc = ""
.Subject = "Upcoming Event In Your Clients' Account(s)"
.display
.HTMLBody = str1 & RangetoHTML(Event_Table_Data) & STR2 & RangetoHTML(Event2_Table_Data)& STR3 & .HTMLBody
.SEND
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
MsgBox ActiveSheet.Name ‘Used for testing purposes only
End If
Next WS
End Sub

How to turn off read only mode when a workbook is opened?

I have a macro attached to a shared file which I scheduled to run every day. It doesn't save the workbook on completion.
I believe this is because the shared document opens in read only mode.
The macro searches cell values and if they meet the relevant conditions, the cell is highlighted red and the text inside the cell is replaced. The macro is set to save at the end.
Public Sub SendEmailReminder2()
Dim lSecurity As Long
lSecurity = Application.AutomationSecurity
'so the workbook doesn't open in protected view
Application.AutomationSecurity = msoAutomationSecurityLow
Dim x As Long
Dim c As Range
Dim OutApp As Object
Dim strbody As String
Dim wb As Workbook
Set wb = Workbooks.Open("insert file path")
Set c = Range("C2")
'loop while cell is not empty
Do While Len(c.Value) > 0
If c.Value <= Date - 45 Then
c.Interior.Color = vbRed
c.Offset(0, -1).Interior.Color = vbRed
c.Offset(0, -2).Interior.Color = vbRed
c.Value = "Email Sent " & Date
'build the message
strbody = strbody & vbCrLf & c.Offset(0, -2) & " - " & _
c.Offset(0, -1) & " needs to be removed from New Releases"
End If
Set c = c.Offset(1, 0) 'next cell
Loop
Set OutApp = CreateObject("Outlook.Application")
On Error Resume Next
With OutApp.CreateItem(0)
.To = ""
.CC = ""
.BCC = ""
.Subject = ""
.Body = strbody
.Send 'or use .Send
End With
On Error GoTo 0
Set OutApp = Nothing
Application.DisplayAlerts = False
wb.Save
Application.DisplayAlerts = True
Application.AutomationSecurity = lSecurity
End Sub
Try accessing the relevant parameters in the .Open method (full list of parameters found here)
Dim fn As String
fn = "insert file path"
Set wb = Workbooks.Open(Filename:=fn, _
ReadOnly:=False, _
IgnoreReadOnlyRecommended:=True)

How to attach an Excel sheet to an Outlook email?

I'm trying to fix one issue which is attaching a file.
I have a TABLE with list of people and their names and a condition(Y/N) column.
Column 1(Name) Column 2(Email) Column 3 (Condition Y/N)
I want to send emails to all people in the TABLE whose name matches with the unique values (name) in one of the columns in Sheet 1.
So I want something that looks up the column in Sheet 1 and maybe changes the Condition to Y in the TABLE for all unique names found in that Column in Sheet 1.(I can FILTER my TABLE in POWER QUERY to show only the rows with Condition "Y").
When the SINGLE email pops up (with the all people in the "To",) I want Sheet 1 or Sheet 2 to be attached to the email.
Option Explicit
Public Sub SendEmail()
' For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
' Working in Office 2000-2016
' Adapted by Ricardo Diaz ricardodiaz.co
Dim OutApp As Object
Dim OutMail As Object
Dim sourceTable As ListObject
Dim evalRow As ListRow
Dim counter As Long
Dim toArray() As Variant
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set sourceTable = Range("Table6").ListObject ' -> Set the table's name
On Error GoTo cleanup
' Loop through each table's rows
For Each evalRow In sourceTable.ListRows
If evalRow.Range.Cells(, 2).Value Like "?*#?*.?*" And _
LCase(evalRow.Range.Cells(, 3).Value) = "yes" Then
ReDim Preserve toArray(counter)
toArray(counter) = evalRow.Range.Cells(, 2).Value
counter = counter + 1
End If
Next evalRow
' Setup the email
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
' Add gathered recipients
For counter = 0 To UBound(toArray)
.Recipients.Add (toArray(counter))
Next counter
.Subject = "Reminder"
.Body = "Dear All" _
& vbNewLine & vbNewLine & _
"Please comply with the transfers in the attached file. " & _
"Look up for your store and process asap."
'You can add files also like this
'.Attachments.Add ("C:\test.txt") ' -> Adjust this path
.Display ' -> Or use Display
End With
On Error GoTo 0
Set OutMail = Nothing
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
Code to Attach sheet 1 (doesn't work)
file_name_import = Format(Now, "yyyy-mm-dd hh-mm-ss")
file_name_import = file_name_import & " - File 1.xlsx"
Worksheets("Sheet 1").Copy
ChDir "H:\Folder 1\Folder 2\Folder 3\Folder 4\"
ActiveWorkbook.SaveAs Filename:= _
"H:\Folder 1\Folder 2\Folder 3\Folder 4\File 1" & file_name_import, _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
.Attachments.Add "H:\Folder 1\Folder 2\Folder 3\Folder 4\File 1\" & file_name_import
I want to add code so my email pops up (with all required people in "To" and) with the attachment.
Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
Public Sub AttachFileToEmail()
Dim OutApp As Object
Dim OutMail As Object
Dim sourceTable As ListObject
Dim evalRow As ListRow
Dim counter As Long
Dim toArray() As Variant
Dim strDir As String
Dim file_name_import As String
Dim fName As String
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
' Excel details not recreated, not needed for this question
file_name_import = Format(Now, "yyyy-mm-dd hh-mm-ss")
file_name_import = file_name_import & " - File 1.xlsx"
' Subscript out of range error would be bypassed due to poor error handling
'Worksheets("Sheet 1").Copy
Worksheets("Sheet1").Copy
' Trailing backslash error would be bypassed due to poor error handling
'ChDir "H:\Folder 1\Folder 2\Folder 3\Folder 4\"
strDir = "C:\Folder 1\Folder 2\Folder 3\Folder 4\"
Debug.Print strDir
' Backslash already at end of strDir
fName = strDir & "File 1" & file_name_import
Debug.Print fName
ActiveWorkbook.SaveAs FileName:=fName, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
' Setup the email
Set OutMail = OutApp.CreateItem(0)
' Do not use On Error Resume Next without a specific reason for bypassing errors
' Instead fix the errors now that you can see them
With OutMail
' Excel details not recreated, not needed for this question
.Subject = "Reminder"
.Body = "Dear All" _
& vbNewLine & vbNewLine & _
"Please comply with the transfers in the attached file. " & _
"Look up for your store and process asap."
.Attachments.Add fName
.Display
End With
Set OutMail = Nothing
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
The idea here is to copy the sheet to a new file and save it in you temp folder. Then attach it to your email
Option Explicit
Public Sub SendEmail()
' For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
' Working in Office 2000-2016
' Attachment code based on: http://www.vbaexpress.com/kb/getarticle.php?kb_id=326
' Adapted by Ricardo Diaz ricardodiaz.co
Dim OutApp As Object
Dim OutMail As Object
Dim sourceTable As ListObject
Dim evalRow As ListRow
Dim newBook As Workbook
Dim newBookName As String
Dim counter As Long
Dim toArray() As Variant
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set sourceTable = Range("Table1").ListObject
On Error GoTo Cleanup
' Save current file to temp folder (delete first if exists)
ThisWorkbook.Worksheets("Sheet1").Copy
Set newBook = ActiveWorkbook
newBookName = "AttachedSheet.xlsx"
On Error Resume Next
Kill Environ("temp") & newBookName
On Error GoTo 0
Application.DisplayAlerts = False
newBook.SaveAs Environ("temp") & newBookName
Application.DisplayAlerts = True
' Loop through each table's rows
For Each evalRow In sourceTable.ListRows
If evalRow.Range.Cells(, 2).Value Like "?*#?*.?*" And LCase(evalRow.Range.Cells(, 3).Value) = "yes" Then
ReDim Preserve toArray(counter)
toArray(counter) = evalRow.Range.Cells(, 2).Value
counter = counter + 1
End If
Next evalRow
' Setup the email
Set OutMail = OutApp.CreateItem(0)
With OutMail
' Add gathered recipients
For counter = 0 To UBound(toArray)
.Recipients.Add (toArray(counter))
Next counter
.Subject = "Reminder"
.Body = "Dear All" _
& vbNewLine & vbNewLine & _
"Please contact us to discuss bringing " & _
"your account up to date"
'You can add files also like this
.Attachments.Add newBook.FullName ' -> Adjust this path
.Display ' -> Or use Display
End With
Set OutMail = Nothing
Cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
Let me know if it works

How can I send an automatic e-mail when any of certain range of cells' value has changed

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

pause excel VBA until user saves a copy of a file

What is the correct syntax for pausing a VBA until the user saves an excel attachment? In the VB below the user is prompted upon opening the workbook with a selection, if that selection is yes then another message box appears asking them to fill out a form and save. I am trying to pause the VB until save is clicked. However, I am getting many compile errors currently. The lines with a ** ** were added to try and accomplish thisThank you :).
VB
Private Sub Workbook_Open()
Dim WS As Worksheet, Rng As Range, c As Range
Dim OutApp As Object, OutMail As Object
Dim Msg As String, Addr As String, FName As String, i As Long
Dim obj As Object
**Dim MyDoc As Document**
Dim MyFileCopy As String
Dim intAnswer As Integer
'define path
MyFileCopy = "L:\NGS\HLA LAB\total quality management\QC & QA\DOSE reports\DOSE reporting form Attachment.xlsx"
'open sheet
Sheets("Email").Activate
intAnswer = MsgBox("Are there any issues to report", vbYesNoCancel)
Select Case intAnswer
Case vbYes
Range("D2").Value = "x"
MsgBox ("Please select an issue and save"), vbExclamation
'create a separate sheet2 to mail out and pause VB
Sheets(2).Copy
Set wkb = ActiveWorkbook
With wkb
**Set MyDoc = Documents.Add
MyDoc.SaveAs "MyFileCopy.xlsx"
DoEvents
Do
Loop Until MyDoc.Saved
.Close True**
End With
Case vbCancel
Application.SendKeys "%{F11}", True
Case Else
Range("C2").Value = "x"
End Select
'create connection, check condition, send email
Set OutApp = CreateObject("Outlook.Application")
Set WS = ThisWorkbook.Sheets("Email")
With WS
Set Rng = .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
End With
For Each c In Rng
Msg = "For " & WS.Cells(2, 2) & Chr(14) & Chr(14)
For i = 3 To 4
If LCase(WS.Cells(2, i)) = "x" Then
Msg = Msg & " -" & WS.Cells(1, i) & Chr(14)
End If
Next
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = c
.CC = ""
.BCC = ""
.Subject = "Daily Operational Safety Briefing"
.Body = Msg
If Range("D2").Value & Chr(14) = "x" Then .Attachments.Add MyFileCopy, 1
.Send
End With
Next c
Set OutMail = Nothing
Set OutApp = Nothing
'confirm message sent, clear sheet, and delete copy
MsgBox "The data has been emailed sucessfully.", vbInformation
Range("C2:D2").ClearContents
Kill MyFileCopy
'Exit and do not save
Application.Quit
ThisWorkbook.Close SaveChanges:=False
End Sub

Resources