I have found the following Macro and used it to my needs to copy range and create an email, I have copied the same code into several sheets, couple of things change in each code the range, email addresses & subject. How can I stack all these macros into one:
Sub Macro_Qu()
'
' Macro_Qu Macro
' Don't forget to copy the function RangetoHTML in the module.
' Working in Office 2000-2010
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set rng = Nothing
On Error Resume Next
Set rng = Sheets("Qusai").Range("A2:J20").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "Qu#msn.com"
.CC = ""
.BCC = ""
.Subject = "Test"
.HTMLBody = RangetoHTML(rng)
.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
Just pass the values that change as parameters:
Sub Test
Macro_Qu Sheets("Qusai").Range("A2:J20"), "Qu#msn.com", "Test"
End Sub
Sub Macro_Qu(parmRng As Range, parmTo As String, parmSubject As String)
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set rng = Nothing
On Error Resume Next
Set rng = parmRng.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = parmTo
.CC = ""
.BCC = ""
.Subject = parmSubject
.HTMLBody = RangetoHTML(rng)
.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
You can use this to call other macros from inside another macro:
call <macro name>
However, if you're starting to get this complex it might be time to learn VBA :)
Related
The following code allows me to select a range of cells using in a range of a excel sheet and send that as an email. However, pictures or images withing the range are not selected. How do i do that
Sub Mail_Selection_Range_Outlook_Body()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Don't forget to copy the function RangetoHTML in the module.
'Working in Excel 2000-2016
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
'Set rng = Nothing
' On Error Resume Next
'Only the visible cells in the selection
'Set rng = Selection.SpecialCells(xlCellTypeVisible)
'You can also use a fixed range if you want
Set rng = Sheets("Sheet1").Range("B8:M108").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", 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 = Worksheets("Email").Range("A10").Value
.CC = Worksheets("Email").Range("B10").Value
.BCC = ""
.Subject = "This is the Subject line"
.HTMLBody = RangetoHTML(rng)
.Send 'or use .Display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
I am working on an Excel workbook to track appointments and to send an email to advise of the appointment.
I put together code to open an email in Outlook with inputs pulled from the Excel sheet.
Sub ButtonREMINDER41_Click()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Set rng = Nothing
On Error Resume Next
' Only send the visible cells in the selection.
Set rng = Selection.SpecialCells(xlCellTypeVisible)
Set rng =
Sheets("Sheet1").RangeToHtml("D4:D12").SpecialCells(xlCellTypeVisible, xlTextValues)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected. " & _
vbNewLine & "Please correct and try again.", 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 = Range("$F$41")
.CC = Range("$B$41")
.BCC = ""
.Subject = "Upcoming Scheduled Appointment"
.HTMLBody = Range("$N$41")
' In place of the following statement, you can use ".Display" to
' display the e-mail message.
.Display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
I am trying to also book an appointment in the receiver's calendar.
I would like an email generated with a meeting attachment for the appointment.
Would anyone be so kind and help me out with my problem? I have this example table:
I would like to send a personalized email for each row, this is what I got so far:
Sub SendEmails()
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("A").Cells.SpecialCells(xlCellTypeConstants)
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.Subject = "Project" & Sheets("Sheet1").Range("C").Value ' insert subject from column C
.HTMLBody = "<p>Hello " & Sheets("Sheet1").Range("B").Value &"</p>" & _ ' insert Name from column B
"<p><strong><u>This is a test email</u></strong></p>"
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
I would like to have data from columns B and C in the email, but I have no idea how to reference them in For each loop and how to put them to the place I want.
Thank you
Try this code : (I changed 3 lines in your code, I marked Them with (X))
Sub SendEmails()
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("A").Cells.SpecialCells(xlCellTypeConstants)
i = cell.Row '(X)
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.Subject = "Project" & Sheets("Sheet1").Range("C" & i).Value '(X)
.HTMLBody = "<p>Hello " & Sheets("Sheet1").Range("B" & i).Value & "</p>" & "<p><strong><u>This is a test email</u></strong></p>" '(X)
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
Instead if using a Range Object you store the content of the Range you are using into a matrix (2D Array)
Now you can access the "cells" by indexing your array. So content of column B would be myArray(rowNumber,2)
Sub SendEmails()
Dim OutApp As Object
Dim OutMail As Object
Dim rng As Variant
myArray= ThisWorkbook.Sheets("Sheet1").Range("A1:C4")
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
For i = 2 To UBound(myArray)
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = myArray(i, 1)
.Subject = "Project" & myArray(i, 3)
.HTMLBody = "<p>Hello " & myArray(i, 2) & "</p>" & _
"<p><strong><u>This is a test email</u></strong></p>"
.Display
End With
Next i
Try it like this.
In column A : Names of the people
In column B : E-mail addresses
In column C:Z : Filenames like this C:\Data\Book2.xls (don't have to be Excel files)
The Macro will loop through each row in "Sheet1" and if there is a E-mail address in column B
and file name(s) in column C:Z it will create a mail with this information and send it.
Sub Send_Files()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range
With Application
.EnableEvents = False
.ScreenUpdating = False
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 = "Testfile"
.Body = "Hi " & cell.Offset(0, -1).Value
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
https://www.rondebruin.nl/win/s1/outlook/amail6.htm
I have been trying to add a button where it pastes the content of a certain range into an Outlook email. By doing so, I'm using the following code:
Private Sub CommandButton4_Click()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Range("P25:P32,Q25:Q32,R25:R32,S25:S32,T25:T32").Select
Set rng = Nothing
On Error Resume Next
Set rng = Selection.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected"
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 = Range("F22").Value
.CC = ""
.BCC = ""
.Subject = Range("F23").Value
.HTMLBody = RangetoHTML(rng)
If Toggle_3.Value = True Then
.Display
ElseIf Toggle_4.Value = True Then
.Send
End If
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
Call SaveFile
End Sub
At line 7 of the code I used to have "P25:T32", but I changed it to that because I thought that might've been what caused the error.
When clicking the button, it gives me the error message:
Sub or function is not defined
and it highlights the .HTMLBody = RangetoHTML(rng) line.
What am I doing wrong?
I was missing the Function RangetoHTML(rng As Range) as Axel Richter commented.
I have code to take a copy of a select worksheet but am haveing difficulties directing which draft folder in outlook to send the draft email to. The name of the folder I want to send the draft email to is "Draft NDIC". Here is the code:
Sub Mail_Body_NDIC()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set rng = Nothing
Set rng = Sheets("NDIC Renewals").UsedRange
'You can also use a sheet name
'Set rng = Sheets("YourSheet").UsedRange
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "dvandervieren#enerplus.com"
.CC = ""
.BCC = ""
.Subject = "NDIC Renewals for the Next 90 Days"
.Body = ""
.HTMLBody = RangetoHTML(rng)
.Save 'or use .Display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
"You need to use the .Move method, with the olDestFolder as the argument." David Van der Vieren
http://blog.saieva.com/2010/03/27/move-messages-to-folders-with-outlook-vba/