How do I select more than one sheet and send as workbook

[Erays]

Option Explicit

Sub EmailandSaveCellValue()
'Variable declaration
Dim oApp As Object, _
oMail As Object, _
WB As Workbook, _
FileName As String, MailSub As String, MailTxt As String
'Set email details; Comment out if not required
Const MailTo = "some1@someone.com"
Const MailCC = "some2@someone.com"
Const MailBCC = "some3@someone.com"
MailSub = "Please review " & Range("Subject")
MailTxt = "I have attached " & Range("Subject")
'Turns off screen updating
Application.ScreenUpdating = False
'Makes a copy of the active sheet and save it to
'a temporary file
ActiveSheet.Copy
Set WB = ActiveWorkbook
FileName = Range("Subject") & " Text.xls"
On Error Resume Next
Kill "C:\" & FileName
On Error Goto 0
WB.SaveAs FileName:="C:\" & FileName
'Creates and shows the outlook mail item
Set oApp = CreateObject("Outlook.Application")
Set oMail = oApp.CreateItem(0)
With oMail
.To = MailTo
.Cc = MailCC
.Bcc = MailBCC
.Subject = MailSub
.Body = MailTxt
.Attachments.Add WB.FullName
.Display
End With
'Deletes the temporary file
WB.ChangeFileAccess Mode:=xlReadOnly
Kill WB.FullName
WB.Close SaveChanges:=False
'Restores screen updating and release Outlook
Application.ScreenUpdating = True
Set oMail = Nothing
Set oApp = Nothing
End Sub

[Ivan F Moala]

What is the criteria for the Sheets you want to select, eg 1st 3 sheets, sheets that start with Send ?? etc.

[Erays]

I just want to be able to select the sheets and run the macro

[MWE]

I just want to be able to select the sheets and run the macro
How do you want to select the sheets?


by holding down the Cntl Key and clicking on the tab names?
by selecting from a form?
some other method?

Assuming you wish to use #1, you need to insert a loop that will copy all selected sheets to the target workbook. As an example of processing a selection of multiple worksheets, the following code will display the names for all selected sheets:



Dim ws As Worksheet
For Each ws In ActiveWorkbook.Windows(1).SelectedSheets
MsgBox ws.Name
Next ws

[JonPeltier]

Who needs a loop?


ActiveWorkbook.Windows(1).SelectedSheets.Copy

This copies the selected sheets into a new workbook.

- Jon
-------
Jon Peltier, Microsoft Excel MVP
Peltier Technical Services
Tutorials and Custom Solutions
http://PeltierTech.com/
_______

[Justinlabenne]

This method may not be what you want, it uses SendMail, but it works for me. This won't work for you if you really need to put text in the message body, etc..
but you specify the sheets in the Array, specify the email address', then run it. Obviously this assumes sheet names and address' are static, if it's not what your looking for, disregard.


Option Explicit

Sub TwoSheetsAndYourOut()
Dim NewName As String
Dim nm As Name
Dim ws As Worksheet
If MsgBox("Copy specific sheets to a new workbook" & vbCr & _
"New sheets will be pasted as values, named ranges removed" _
, vbYesNo, "NewCopy") = vbNo Then Exit Sub
With Application
.ScreenUpdating = False
' Copy specific sheets
' *SET THE SHEET NAMES TO COPY BELOW*
' Array("Sheet Name", "Another sheet name", "And Another"))
' Sheet names go inside quotes, seperated by commas
On Error GoTo ErrCatcher
Sheets(Array("Copy Me", "Copy Me2")).Copy
' Paste sheets as values
For Each ws In ActiveWorkbook.Worksheets
ws.[A1:IV65536].Copy
ws.[A1].PasteSpecial Paste:=xlValues
Next ws
Application.CutCopyMode = False
' Remove named ranges
For Each nm In ActiveWorkbook.Names
nm.Delete
Next nm
' Save it with the name "Test" and in the same directory as original
With ActiveWorkbook
.SaveAs ThisWorkbook.Path & "\test.xls"
.SendMail "MailAddy@you.com", "Subject Here"
.Close False
End With
Kill ThisWorkbook.Path & "\test.xls"
.ScreenUpdating = True
End With
Exit Sub
ErrCatcher:
MsgBox "Specified sheets do not exist within this workbook"
End Sub

[Erays]

This is the one that works for me. It emails from a value in a cell and names the book from a value in a cell.



Sub EmailWithOutlookBook()
'Variable declaration
Dim oApp As Object, _
oMail As Object, _
WB As Workbook, _
FileName As String
'Turns off screen updating
Application.ScreenUpdating = False
'Makes a copy of the active sheet and save it to
'a temporary file
ActiveWorkbook.Windows(1).SelectedSheets.Copy
Set WB = ActiveWorkbook
FileName = Cells(8, 3).Value & " Reis.xls"
On Error Resume Next
Kill "C:\" & FileName
On Error GoTo 0
WB.SaveAs FileName:="C:\" & FileName
'Creates and shows the outlook mail item
Set oApp = CreateObject("Outlook.Application")
Set oMail = oApp.CreateItem(0)
With oMail
'Uncomment the line below to hard code a recipient
.To = Cells(7, 11).Value
.Cc = Cells(8, 11).Value
.Bcc = Cells(9, 11).Value
'Uncomment the line below to hard code a subject
.Subject = "Here are the reis In workbook form, if you have questions please call "
'.Body = "I Have attached to this email the totol loss template for claim Number " & Cells(6, 3).Value
.Attachments.Add WB.FullName
.Display
End With
'Deletes the temporary file
WB.ChangeFileAccess Mode:=xlReadOnly
Kill WB.FullName
WB.Close SaveChanges:=False
'Restores screen updating and release Outlook
Application.ScreenUpdating = True
Set oMail = Nothing
Set oApp = Nothing
End Sub