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

Code:

---

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

---

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

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

Quote:

---

Originally Posted by Erays

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

---

How do you want to select the sheets?

1. by holding down the Cntl Key and clicking on the tab names?
2. by selecting from a form?
3. 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:

Code:

---

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

---

Who needs a loop?

Code:

---

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/
_______

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.

Code:

---

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

---

Quote:

---

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.

---

Code:

---

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

---