Rob342
02-28-2011, 07:34 AM
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
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