Copy Multiple Sheets, Except Q

S

Seanie

How could I tweak the code below that will copy all sheets from my
ActiveWorkbook EXCEPT for sheets A;B and C?

Code below will copy 2 specified sheets, but I want to twist this
around as I have a large number to copy and don't want to hard code
them as below

Set Sourcewb = ActiveWorkbook
Sourcewb.Sheets(Array("Header", "Order")).Copy
Set Destwb = ActiveWorkbook
 
J

Joel

Sub CopyBook()

First = True
For Each Sht In ThisWorkbook.Sheets
Select Case Sht.Name

Case "A", "B", "C"
'Do Nothing
Case Else
If First = True Then
'Create New workbook
Sht.Copy
Set NewBk = ActiveWorkbook
First = False
Else
With NewBk
Sht.Copy after:=.Sheets(.Sheets.Count)
End With
End If
End Select
Next Sht

End Sub
 
J

Joel

The test using strings ze case sensitive

from
Select Case Sht.Name
to
Select Case Ucase(Sht.Name)

The make sure the name in this statement is all capital

Case "A", "B", "C"
 
S

Seanie

Great, I got it to work as below. Finally how could I place a Msg Box
pop up, if there are no sheets to copy, i.e. the only sheets that are
in the source workbook are A,B,C,D?


First = True
For Each sht In ThisWorkbook.Sheets
Select Case sht.Name


Case "Header", "A", "B", "C", "D"
'Do Nothing
Case Else
If First = True Then
'Create New workbook
sht.Copy
Set Destwb = ActiveWorkbook
First = False
Else
With Destwb
sht.Copy after:=.Sheets(.Sheets.Count)
End With
End If
End Select
Next sht
 
J

Joel

Add and IF statement at the bottom like below.

First = True
For Each sht In ThisWorkbook.Sheets
Select Case sht.Name


Case "Header", "A", "B", "C", "D"
'Do Nothing
Case Else
If First = True Then
'Create New workbook
sht.Copy
Set Destwb = ActiveWorkbook
First = False
Else
With Destwb
sht.Copy after:=.Sheets(.Sheets.Count)
End With
End If
End Select
Next sht

If First = True then
msgbox("No sheets found to copy")
End IF
 
S

Seanie

Thanks, It debugs with message "Copy Method of Worksheet class failed"
on text

sht Copy

This is when there are no sheets apart from A,B,C,D. If I have a sheet
other than those, code works fine
 
J

Joel

Your description of the failure doesn't make sense. If you have only A,B,C,D
then you will never do a copy so your won't get to the failure you are
descriping. Post all your code so I can see the changes you made.
 
S

Seanie

I won't need to do a copy, but as the file goes out to a couple of
users, they might just action the macro and hence that is why I'd like
to see the Msb Box, wouldn't look good if they did and then they get
the debug message. As I've said code works fine if I have a sheet to
copy, but if not debugs as above. Full Code is:-

Sub Mail_Database()
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim strbody As String

With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With

Set Sourcewb = ActiveWorkbook

'Copy the sheets to a new workbook
First = True
For Each sht In ThisWorkbook.Sheets
Select Case sht.Name


Case "A", "B", "C", "D"
'Do Nothing
Case Else
If First = True Then
'Create New workbook
sht.Copy
Set Destwb = ActiveWorkbook
First = False
Else
With Destwb
sht.Copy after:=.Sheets(.Sheets.Count)
End With
End If
End Select
Next sht

If First = True Then
MsgBox ("There are no Historic Orders to E-Mail")
End If


With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
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
FileExtStr = ".xls": FileFormatNum = 56

End If
End If
End With

TempFilePath = Environ$("temp") & "\"
TempFileName = "Database Extraction from " & Sourcewb.Name & " " &
Format(Now, "dd-mmm-yy h-mm") & "~"

ActiveWindow.TabRatio = 0.908


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 = "[email protected]"
.CC = ""
.BCC = ""
.Subject = "Database of Orders"
.Body = ""
.Attachments.Add Destwb.FullName
.ReadReceiptRequested = True
.SendUsingAccount = OutApp.Session.Accounts.Item(1)
.Send
End With
On Error GoTo 0
.Close savechanges:=False
End With

Kill TempFilePath & TempFileName & FileExtStr

Set OutMail = Nothing
Set OutApp = Nothing

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
 
J

Joel

I ran you code and didn't get any problems on the line

sht.Copy

This line has a period between sht and copy which you didn't have in the
previous posting where you said you had a problem. I tried repeating the
problem by using different number of sheets in my workbook but still didn't
repeat your problem.

When you use COPY on a sheet without the parameter AFTER or BEFORE excel
creates a new workbook. The new workbook only has one sheet (the one you
copied) and doesn't have any macros. I like this procedure better than using
Workbooks.Add because the Add method will create a new workbook with 3 blank
worksheets (or whatever you have the defualt number of sheets set to in Tools
- Option).

I would also rewrite this section of code

With Destwb
If First = False then
.SaveAs TempFilePath & TempFileName &FileExtStr, _
FileFormat:=FileFormatNum
End if
With OutMail
.To = "[email protected]"
.CC = ""
.BCC = ""
.Subject = "Database of Orders"
If First = true then
.Body = "There are no Historic Orders to E-Mail"
Else
.Body = ""
.Attachments.Add Destwb.FullName
End if
.ReadReceiptRequested = True
.SendUsingAccount = OutApp.Session.Accounts.Item(1)
.Send
End With
.Close savechanges:=False
End With

If First = False then
Kill TempFilePath & TempFileName & FileExtStr
End If
 
Top