Solved: copying slected sheets to a new WB then e mail the Workbook

[Rob342]

Hi
Can anybody help to solve this problem
I have a Excel Workbook is 20mb in size,made up of 20 + sheets, i am extracting the required sheets into a new Workbook.
I would then like to E Mail the copy with the selected sheets in the new workbook to approx 12 recipients.

I found the codes for selecting the required sheets into a new workbook and the code for E Mailing, but i am trying to combine the whole operation into 1 command button, i also want the command button deleted in the new workbook.

Any help would be appreciated.

Copy of code as follows


Option Explicit
Sub CommandButton1_Click()
Dim NewName As String
Dim wb As Workbook
Dim nm As Name
Dim ws As Worksheet
Dim wkscmdBttn As OLEObject
Dim wksCopy As Worksheet
Dim oAPP As Object
Dim oMail As Object
Dim recipients As String


If MsgBox("Copy specific sheets to a new workbook" & vbCr & _
"New Sheets Will Be Pasted As Values Only" _
, vbYesNo, "NewCopy") = vbNo Then Exit Sub
Application.EnableEvents = False
Application.ScreenUpdating = False

'// Copy specific sheets as in the named Array
On Error GoTo ErrCatcher
Sheets(Array("Landrover", "Honda", "Erd Multi", "Wrd Multi", "Tamworth", "Summary")).Copy
On Error GoTo 0

'//Paste copy sheets as values only
'//Remove External Links, Hperlinks and hard-code formulas
'//Make sure A1 is selected on all sheets

For Each ws In ActiveWorkbook.Worksheets
ws.Cells.Copy
ws.[A1].PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Cells(1, 1).Select
ws.Activate
Next ws
Cells(1, 1).Select


'//Display Input box to name new file
NewName = InputBox("Please Specify the name of your new workbook", "New Copy")

'//Save it with the NewName and in the same directory as original
ActiveWorkbook.SaveCopyAs ThisWorkbook.Path & "\" & NewName & ".xls"



'// Email Function
Set oAPP = CreateObject("Outlook.Application")
Set oMail = oAPP.CreateItem(0)
With oMail
'.recipients.Add recipients
.To = "********@********.co.uk (********@********s.co.uk)"
.Cc = ""
.Bcc = ""
.subject = " Copy of the KPI sheets"
.Attachments.Add wb.KPI.Test & ".xls"

.Send

End With



ActiveWorkbook.Close SaveChanges:=False
Application.ScreenUpdating = True
Application.EnableEvents = True
'// release outlook
Set oMail = Nothing
Set oAPP = Nothing
Exit Sub

ErrCatcher:
MsgBox "Specified sheets do not exist within this workbook"
End Sub

[GTO]

Try: http://www.vbaexpress.com/kb/getarticle.php?kb_id=326

Not well read/tested, but I think this would work. I substituted .Display as Outlook pops up a warning for .Send.


Sub CommandButton1_Click()
Dim NewName As String
Dim wb As Workbook
Dim nm As Name
Dim ws As Worksheet
Dim wkscmdBttn As OLEObject
Dim wksCopy As Worksheet
Dim oAPP As Object
Dim oMail As Object
Dim recipients As String
Dim strFullname As String
If Not MsgBox("Copy specific sheets to a new workbook" & vbCr & _
"New Sheets Will Be Pasted As Values Only" _
, vbYesNo, "NewCopy") = vbYes Then Exit Sub

Application.EnableEvents = False
Application.ScreenUpdating = False

'// Copy specific sheets as in the named Array
On Error GoTo ErrCatcher
Sheets(Array("Landrover", "Honda", "Erd Multi", "Wrd Multi", "Tamworth", "Summary")).Copy
On Error GoTo 0

Set wb = ActiveWorkbook

For Each ws In wb.Worksheets
ws.UsedRange.Value = ws.UsedRange.Value
Next ws

'//Display Input box to name new file
NewName = InputBox("Please Specify the name of your new workbook", "New Copy")

'//Save it with the NewName and in the same directory as original
wb.SaveAs ThisWorkbook.Path & "\" & NewName & ".xls"

'// Email Function
Set oAPP = CreateObject("Outlook.Application")
Set oMail = oAPP.CreateItem(0)
With oMail
'.recipients.Add recipients
.To = "********@********.co.uk"
.Cc = ""
.Bcc = ""
.Subject = " Copy of the KPI sheets"
.Attachments.Add wb.FullName

'.Send
.display
End With

strFullname = wb.FullName

wb.Close SaveChanges:=False
Application.ScreenUpdating = True
Application.EnableEvents = True

On Error Resume Next
Kill strFullname
On Error GoTo 0


'// release outlook
Set oMail = Nothing
Set oAPP = Nothing
Exit Sub

ErrCatcher:
MsgBox "Specified sheets do not exist within this workbook"
End Sub
Hope that helps,

Mark

[Rob342]

Hi Mark

Thanks for the info, i have printed the link i will look at it tomorrow.
I have tried your code and it works apart from the pivot table that is in each of the sheets, when i deleted these it was ok.
It didnt delete the command button though
Can i come back to you when i have read Ken's link, if you dont mind

Rob

[softman]

I had the same type of requirment and found very helpful tips for emailing here: http://www.rondebruin.nl/sendmail.htm

[Rob342]

Hi Mark / Softman

I did look at this site some usefull Code on there.

Managed to get the sheet working and hide the command button on the e mail sheet, now work a treat.

I have posted the code back, so if anybody has the same requirement then feel free to use. Please note the 1st part of the routine updates the pivot tables on all sheets.
The email sheet is made up as
column A Name of person
column B E mail address
Column C Y or N (Y if you want to send e mail with copy of workbook)

In standard Module
Command button is on E Mail sheet.


[VBA]
Option Explicit
Option Private Module

Sub CommandButton1_Click()
'// Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.

Dim Wb As Workbook
Dim WB1 As Workbook
Dim ws As Worksheets
Dim OutApp As Object
Dim OutMail As Object
Dim Cell As Range
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim wkscmdBttn As OLEObject


Set Wb = ActiveWorkbook
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Sheets("EMails").Select
Worksheets("EMails").OLEObjects.Visible = True ' added here
'// Activate refresh pivot table procedure on all KPI Sheets
Sheets("*****").Select
Range("AH55").Select
ActiveSheet.PivotTables("*****").PivotCache.Refresh
Sheets("*****").Select
Range("AH55").Select
ActiveSheet.PivotTables("*****").PivotCache.Refresh
Sheets("*****").Select
Range("AH55").Select
ActiveSheet.PivotTables("*****").PivotCache.Refresh
Sheets("*****").Select
Range("AH55").Select
ActiveSheet.PivotTables("*****").PivotCache.Refresh
Sheets("*****").Select
Range("AH55").Select
ActiveSheet.PivotTables("*****").PivotCache.Refresh
Sheets("*****").Select
Range("AH55").Select
ActiveSheet.PivotTables("*****").PivotCache.Refresh
Sheets("*****").Select
Range("AH55").Select
ActiveSheet.PivotTables("*****").PivotCache.Refresh
'// Return to EMails sheet for E-Mail facility to work.
Sheets("EMails").Select
Wb.Save

'// Make a copy of the file/open it/mail it/then delete it when sent.
TempFilePath = "C:\Temp\"
TempFileName = "Copy of " & Wb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
FileExtStr = "." & LCase(Right(Wb.Name, _
Len(Wb.Name) - InStrRev(Wb.Name, ".", , 1)))

Wb.SaveCopyAs TempFilePath & TempFileName & FileExtStr
Set WB1 = Workbooks.Open(TempFilePath & TempFileName & FileExtStr)
'// Hide the command button in the copy !!!
Worksheets("EMails").OLEObjects.Visible = False
WB1.Save

With WB1

Set OutApp = CreateObject("Outlook.Application")
On Error GoTo Cleanup
For Each Cell In Columns("B").Cells.SpecialCells(xlCellTypeConstants)
If Cell.Value Like "?*@?*.?*" And _
UCase(Cells(Cell.Row, "C").Value) = "Y" Then
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = Cell.Value
.Subject = "SomeName Data Update"
.Body = "Dear " & Cells(Cell.Row, "A").Value _
& vbNewLine & vbNewLine & _
"Please Find Attached Excel Spreadsheet Data Update"
.Attachments.Add WB1.FullName
'.Attachments.Add ("C:\****\****.xls")
'.Send 'Or use Display.
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next Cell
.Close SaveChanges:=False
End With
Kill TempFilePath & TempFileName & FileExtStr
Cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Quit
End Sub

Many thanks both
Rob