E-Mail form Excel 'selected print area'

  • Thread starter Thread starter patterson_m
  • Start date Start date
P

patterson_m

Can you advise how I change the following routine so that I e-mail only
the selected print areas (I have multiple print areas) on one sheet. Is
this in fact possible/

Thanks

mark

Sub Mail_ActiveSheet()
ActiveSheet.Copy
Dim strDate As String
Dim Addr As String
Dim rng As Range
PrintArea = "$A$1:$E$11"
Addr = PrintArea
Range(Addr).Select
Set rng = Selection
Application.GoTo rng, True
rng.Cells(1).Select
strDate = Format(Date, "dd-mm-yy") & " " & Format(Time, "h-mm-ss")
ActiveWorkbook.SaveAs "Part of " & ThisWorkbook.Name _
& " " & strDate & ".xls"
ActiveWorkbook.SendMail "(e-mail address removed)",
_
"E-Mail Test 1"
ActiveWorkbook.ChangeFileAccess xlReadOnly
Kill ActiveWorkbook.FullName
ActiveWorkbook.Close False
End Sub
 
Ron de Bruin has masses of stuff about mailing spreadsheets on his web-site


As a quick and dirty work-around for what you want to do, why not create a
new workbook, just add the bit of info that you want into that, and then
email that workbook?

Something along these lines:

Public Sub Test()

Range("$A$1:$E$11").Copy

Workbooks.Add

Range("A1").PasteSpecial

ActiveWorkbook.SendMail

End Sub
 
Try this

'It will add a sheet and copy the selection areas on it.
'Mail the sheet and delete it after that

Sub test()
Dim wb As Workbook
Dim destrange As Range
Dim smallrng As Range
Dim newsh As Worksheet
Dim Ash As Worksheet
Application.ScreenUpdating = False
Set Ash = ActiveSheet
Set newsh = Worksheets.Add
Ash.Select
Set destrange = newsh.Cells(LastRow(newsh) + 1, 1)
For Each smallrng In Selection.Areas
smallrng.Copy
destrange.PasteSpecial xlPasteValues
Set destrange = newsh.Cells(LastRow(newsh) + 1, 1)
Next smallrng
newsh.Copy
Set wb = ActiveWorkbook
With wb
.SaveAs "Part of " & ThisWorkbook.Name _
& " " & strdate & ".xls"
.SendMail "(e-mail address removed)", _
"This is the Subject line"
.ChangeFileAccess xlReadOnly
Kill .FullName
.Close False
End With
Application.DisplayAlerts = False
newsh.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Public Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
after:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
 
Back
Top