none
Macro contar hojas y mover a libro con macro vba RRS feed

  • Pregunta

  • Macro contar hojas y mover a libro con macro 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

    domingo, 16 de octubre de 2016 19:48