Macro copiar hojas y pegar libro nuevo

Macro contar hojas y mover a libro con vba

Necesito que alguien me de una idea 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