Macro contar hojas y mover a libro con vba

Necesito urgente que alguien me ayude en la medida de lo posible para una ampliación de macro que estoy realizando, tengo un libro con 40 hojas fijas y a partir de la 40 me va generando hojas con diferentes números, la macro consiste en contar hasta la hoja 40 y mover desde la hoja 40 hasta la ultima hoja generada a un libro con la colocación según se crea y su nombre respectivo. Adjunto macro que estoy realizando que solo me guarda la (Sheets("PRESUPUESTO FINAL"). Select):
Sub GRABAR_PRESUPUESTO_DE_CALCULO()
'
'
'
Dim ws As Worksheet
   'Set wss = Sheets("PRESUPUESTO FINAL") 'Hoja donde actua
    Set ws = Sheets("ALTA PRESUPUESTO1") 'Hoja donde actua
Sheets("GENERAR PRESUPUESTO").Select
Application.ScreenUpdating = False
On Error Resume Next
'ActiveSheet.Shapes("Picture 67").Visible = False 'abrir puerta
'ActiveSheet.Shapes("Picture 63").Visible = True 'abrir puerta
Sheets("PRESUPUESTO FINAL").Select
Dim Nom_Carpeta As String
Nom_Carpeta = ws.Range("K9").Value
If Nom_Carpeta = "" Then
MsgBox "Nombre Invalido." & Chr(13) & "Las carpetas no se crearán", vbOKOnly, "Error!!!"
Exit Sub
End If
Dim Nom_SubCarpeta As String
Nom_SubCarpeta = ws.Range("B1").Value
If Nom_SubCarpeta = "" Then
MsgBox "Nombre Invalido." & Chr(13) & "Las carpetas no se crearán", vbOKOnly, "Error!!!"
Exit Sub
End If
On Local Error Resume Next
MkDir "C:\Users\DAVID CA\Desktop\01-04-16\08-10-16\" & Nom_Carpeta
MkDir "C:\Users\DAVID CA\Desktop\01-04-16\08-10-16\" & Nom_Carpeta & "\" & Nom_SubCarpeta
 Dim RutaArchivo, NombreArchivo As String
Sheets("PRESUPUESTO FINAL").Select
Application.ScreenUpdating = False
EnableEvents = False
 RutaArchivo = "\\MOZART\Presupuestos\HISTORIAL PRESUPUESTARIO DAVID CALLEJA 2014\XSWM01311\ALTA DE PRESUPUESTOS\" & Nom_Carpeta & "\" & Nom_SubCarpeta & "\" & ws.Range("B2") & ".pdf"
 ActiveSheet.Copy
 Dim img As Shape
On Error Resume Next
For Each img In ActiveSheet.Shapes
     If img.Type = 1 Then img.Delete
Next
Dim bot As Button
On Error Resume Next
For Each bot In ActiveSheet.Buttons
     If bot.Type = 1 Then bot.Delete
Next
Rows("1:1").Select
    Selection.EntireRow.Hidden = True
 Application.DisplayAlerts = False
 ActiveSheet.SaveAs Filename:= _
 "C:\Users\DAVID CA\Desktop\01-04-16\08-10-16\" & Nom_Carpeta & "\" & Nom_SubCarpeta & "\" & ws.Range("B2") & ".xlsx"
 'For i = 1 To Sheets.Count
   'Sheets(i).Protect
 'Next i
'ActiveWorkbook.Save
Application.Calculation = xlCalculationAutomatic
ActiveWorkbook.Close False
 Sheets("GENERAR PRESUPUESTO").Select
Range("A1").Select
End Sub