Modification to VBA code to send worksheet range in email using command button

Ben M

New Member
Joined
Aug 13, 2014
Messages
23
Hi,

I would like to start by thanking everyone who posts answers on this forum. I have been using it for years to get answers and have been able to develop a very good understanding of excel in my career thanks to the generosity of others. I will be looking for any unanswered questions and trying to give back as I have received so much.

I knew the day would come when I needed to post a question as I could no longer find the answers I needed and today I have reached that day.

I have managed to peice toghether the below code in Excel 2010 to email part of a worksheet using a command button and it works great. I would just like to tweak it so I can use some cell values for things like email text, to, cc. Also, I would like to make the file name a cell value. This file does not need to be saved, just used in the attachment.

I would like to use the below cell values instead of what is currently being used:

Cell M1 - Subject instead of: .Subject = "xxxxxxxxxx"
Cell M2 - to - instead of: .to = "xxxxxxxxx@xxxxxxx.com"
Cell M3 - cc - instead of: .CC = ""
Cell M4 - Message Body - instead of: .Body = "xxxxxxxxxxxxx"
Cell M5 - File name - instead of: TempFileName = "Selection of " & wb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")

Here is the current code in full:

=========================


Sub Mail_Range()
Dim Source As Range
Dim Dest As Workbook
Dim wb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim OutApp As Object
Dim OutMail As Object
Set Source = Nothing
On Error Resume Next
Set Source = Range("A1:H50").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Source Is Nothing Then
MsgBox "The source is not a range or the sheet is protected, please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set wb = ActiveWorkbook
Set Dest = Workbooks.Add(xlWBATWorksheet)
Source.Copy
With Dest.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial Paste:=xlPasteValues
.Cells(1).PasteSpecial Paste:=xlPasteFormats
.Cells(1).Select
Application.CutCopyMode = False
End With
TempFilePath = Environ$("temp") & "\"
TempFileName = "Selection of " & wb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
If Val(Application.Version) < 12 Then

FileExtStr = ".xls": FileFormatNum = -4143
Else

FileExtStr = ".xlsx": FileFormatNum = 51
End If
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With Dest
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.to = "xxxxxxxxx@xxxxxxx.com"
.CC = ""
.BCC = ""
.Subject = "xxxxxxxxxx"
.Body = "xxxxxxxxxxxxx"
.Attachments.Add Dest.FullName
.Send
End With
On Error GoTo 0
.Close savechanges:=False
End With
Kill TempFilePath & TempFileName & FileExtStr
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

=================

Thanks again,

Ben
 

Excel Facts

How to find 2nd largest value in a column?
MAX finds the largest value. =LARGE(A:A,2) will find the second largest. =SMALL(A:A,3) will find the third smallest
Thanks for your quick reply VoG.

I've put my email address in cell M2 to test this and modified the code:

.to = Range("m2").Value
.CC = Range("m3").Value
.BCC = Range("m4").Value
.Subject = Range("m5").Value
.Body = Range("m6").Value

Unfortunately nothing is happening when I press the button. However, I am not receiving any error message.

M3 and M4 are empty cells, M5 and M6 just say "Test".

I have pasted values my email address from my Outlook address book to be ceratin it is entered correctly but still no email recieved?


<tbody>
</tbody><colgroup><col><col></colgroup>
 
Upvote 0
I think that you will need to qualify the workbook and sheet, something like

.to = wb.sheets("Sheet1").range("M1").value
 
Upvote 0

Forum statistics

Threads
1,213,534
Messages
6,114,184
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top