Dim ct
Dim strDesktopPath

On Error Resume Next
ct = Application.InputBox("Enter Contract Number (5555, 6666, 7777)", "Save As")
strDesktopPath = objWS.SpecialFolders("Desktop")
If ct = "5555" Then
Sheet1.Select
Sheet2.Select
Sheet3.Select
Sheet4.Select
Sheet5.Select
Selection.Cells.Copy
With ActiveWorkbook
.SaveCopyAs Filename:=strDesktopPath & "" & ct & " Report.xls"
End With

Dim VBProj As VBIDE.VBProject
    Dim VBComp As VBIDE.VBComponent
    Dim CodeMod As VBIDE.CodeModule
Set VBProj = ActiveWorkbook.VBProject

Set objWS = CreateObject("WScript.Shell")
For Each VBComp In VBProj.VBComponents
            If VBComp.Type = vbext_ct_Document Then
                Set CodeMod = VBComp.CodeModule
                With CodeMod
                    .DeleteLines 1, .CountOfLines
                End With
            Else
                VBProj.VBComponents.Remove VBComp
            End If
        Next VBComp