Move worksheets to a new workbook
Try this:
Sub MoveSavedSheets()
' This moves sheetswith a specified tab color into a new workbook,
' and saves it on the Desktop, and closes it.
'
' Tab colors were new in version 10
' It will notify the user and exit if a lower version.
Dim wks As Worksheet, wbkSource As Workbook, wbkTarget As Workbook
Dim sName As String, sPath As String
Dim oWSH As Object
If Val(Application.Version) 9 Then
sName = InputBox("Enter a filename")
If sName < "" Then
Set wbkSource = ActiveWorkbook
Application.ScreenUpdating = False
Set wbkTarget = Workbooks.Add
'Move the sheets to wbkTarget
'**Change the ColorIndex value to suit your color.
'**To obtain this, record a macro and select the color.
For Each wks In wbkSource.Sheets
If wks.Tab.ColorIndex = 36 Then wks.Move befo=wbkTarget.Sheets(1)
Next
'Save it to the desktop with the name provided
On Error GoTo ErrorExit
'(As provided by Bob Phillips)
Set oWSH = CreateObject("WScript.Shell")
sPath = oWSH.SpecialFolders("Desktop")
With wbkTarget
.SaveAs sPath & "\" & sName
.Close
End With
End If
Else
MsgBox "This macro requires Excel v10 or higher ! ", vbExclamation +
vbOKOnly
Exit Sub
End If
Regards,
GS
|