PDA

View Full Version : Copying multiple sheets



tomsweddy
06-25-2009, 09:02 AM
hi,

I have the following code which is meant to copy three worksheets into a new workbook and then attatches them into an email, populating its filename too.

I can get this to work for one worksheet but not for three....

Can anyone help me out

It is going wrong at this bit

'Copy the sheet to a new workbook
Worksheets("Section 1").Copy
Worksheets("Section 2").Copy


full Code:
Sub ProduceEmail()
'Working in 2000-2007
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As Variant
Dim OutApp As Object
Dim OutMail As Object

With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set Sourcewb = ActiveWorkbook
'Copy the sheet to a new workbook
Worksheets("Section 1").Copy
Worksheets("Section 2").Copy
Set Destwb = ActiveWorkbook
'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007
'We exit the sub when your answer is NO in the security dialog that you only
'see when you copy a sheet from a xlsm file with macro's disabled.
If Sourcewb.Name = .Name Then
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Your answer is NO in the security dialog"
Exit Sub
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
End With
' 'Change all cells in the worksheet to values if you want
With Destwb.Sheets(2).UsedRange
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
.Cells(2).Select
End With
Application.CutCopyMode = False
'Save the new workbook/Mail it/Delete it
With ActiveSheet


TempFilePath = Environ$("temp") & "\"
'TempFileName = "Your New Employee " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy")
TempFileName = Range("C2").Value & ", CONTRACT, " & Format(Range("C22").Value, "dd.mm.yy")

End With
' FileName = Range("E6").Value
' FileName = Mid(FileName, InStr(FileName, " ") + 1) & " " & _
Left(FileName, InStr(FileName, " ") - 1) & _
", CONTRACT, " & Format(Range("K8").Value, "dd.mm.yy")

Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)
With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.to = ""
.CC = ""
.BCC = ""
.Subject = "Employee Contract"
'.Body = "<p>Dear</p> <br/> <p>Paragraph 2<p/>"
.HTMLBody = .HTMLBody & "<body><font color=#000000><font face=verdana><FONT SIZE=2>"
.HTMLBody = .HTMLBody & "<p><b>CC: Line Manager & Person who sent in VCS</b></p>"
.HTMLBody = .HTMLBody & "<p>Dear</p>"
.HTMLBody = .HTMLBody & "<p>Further to your verbal offer of employment with <b> Nestle UK Ltd/Nestle Purina Petcare UK/Nestle Waters/Nestle Ireland </b>, I have attached your offer letter, contract, medical questionnaire and new starter form. These have also been sent first class post today, along with other associated new starter documents.""</p>"
.HTMLBody = .HTMLBody & "<p>Please do not hesitate to call the New Starter Team if you have any queries</p>"
.HTMLBody = .HTMLBody & "<p>Best Regards</p>"
.HTMLBody = .HTMLBody & "<p><b>*Remove ‘Medical Questionnaire’ for Purina Wisbech (also delete this sentence)</b></p>"
.HTMLBody = .HTMLBody & "</font></font>"
.HTMLBody = .HTMLBody & "<font color=#808080><font face=verdana><FONT SIZE=2>"

.HTMLBody = .HTMLBody & "<p>Your Name<br/>UKI-<b>NBS</b> HR Advisor<br/>New Starter Team</p>"
.HTMLBody = .HTMLBody & "<p>External 0800 5872121<br/>Fax +44 (0)1904 604908<br/>UKI-<b>NBS</b> Right Cost, Right Service, Executed Flawlessly</p>"
.HTMLBody = .HTMLBody & "</font></font></body>"
.Attachments.Add Destwb.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Display 'or use .Send
End With
On Error GoTo 0
.Close savechanges:=False
End With
'Delete the file you have send
Kill TempFilePath & TempFileName & FileExtStr
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

Thanks alot!

Aussiebear
06-25-2009, 10:23 PM
Try changing the code

'Copy the sheet to a new workbook
Worksheets("Section 1").Copy
Worksheets("Section 2").Copy
to
Sheets(Array("Section 1", "Section 2", Section 3")).Copy and see what happens

tomsweddy
06-26-2009, 02:37 AM
This is great but I think there is now a problem with this section.......

' 'Change all cells in the worksheet to values if you want
With Destwb.Sheets(1).UsedRange
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
.Cells(1).Select

Because this code was previosuly only used for one sheet, when I look at my output now, only 1 sheet out of 3 have had their VALUES copied....

Does anyone know how to change this so the three sheets have their values copied??

Thanks