Contar Hojas y mover a libro especifico Vba

Solicito en la medida de lo posible ayuda 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

1 respuesta

Respuesta
2

H o l a : No entendí muy bien lo que necesitas. Podrías explicar qué requieres.

Buenos días,

En primer lugar gracias , necesito importar las hojas de un libro a otro desde la hoja 40 hasta la última con sus nombres de hoja como si lo hiciera manual pero con macros y en la dirección que tengo en la macro adjunta en la petición. 

Le voy explicar como tengo elaborado el libro para la macro que necesito, he creado un libro con el nombre DESIGN DVACHQ222.xlsm y fui creando hojas y borrando a su vez con lo que me quedan hojas con números asignados por office pero nombradas diferentes por mi, su posición de izquierdas a derecha ejemplo:

Hoja1 (Nombre asiginado por mi "CALCULO")

Hoja10(Nombre asignado por mi "GENERARPRESUPUESTO")

Hoja12(Nombre asignado por mi "LISTADO DE COMPRAS")

ETC... la posición de Izquierda a derecha ( la Hoja1 tendría su posición nº1, la Hoja 10 su posición seria nº2 y la Hoja12 tendría su posición 3, y así hasta hasta la posición nº 40, a partir de la posición 40 voy generando hojas que quiero mover a otro libro desde la 40 hasta la ultima creada en la dirección de la macro que adjunto.

Adjunto macro

Sub GRABAR_PRESUPUESTO_DE_CALCULO()
'
' Macro94 Macro
' actualizada 15-05-16
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 "\\MOZART\Presupuestos\HISTORIAL PRESUPUESTARIO DAVID CALLEJA 2014\XSWM01311\ALTA DE PRESUPUESTOS\" & Nom_Carpeta
MkDir "\\MOZART\Presupuestos\HISTORIAL PRESUPUESTARIO DAVID CALLEJA 2014\XSWM01311\ALTA DE PRESUPUESTOS\" & 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
 Application.DisplayAlerts = False
 ActiveSheet.SaveAs Filename:= _
 "\\MOZART\Presupuestos\HISTORIAL PRESUPUESTARIO DAVID CALLEJA 2014\XSWM01311\ALTA DE PRESUPUESTOS\" & 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

Un Cordial Saludo

David.C

Lo que no entiendo es la macro.

Podrías poner los datos, es decir, selecciono las hojas de la 40 en adelante.

¿Quieres copiarlas a dónde? ¿A un archivo nuevo de excel o a un pdf?

¿En cuál ruta quieres guardar el archivo?

Ayúdame solamente con los datos, no me pongas toda la macro.

Buenas noches,

Dirección donde se guarda el libro nuevo excel \\MOZART\Presupuestos\HISTORIAL PRESUPUESTARIO DAVID CALLEJA 2014\XSWM01311\ALTA DE PRESUPUESTOS\" & Nom_Carpeta & "\" & Nom_SubCarpeta & "\" & ws.Range("B2") & ".xlsx"

******************************************************************

Crear Carpeta  y subcarpeta con nombre según celdas en la hoja con nombre "ALTA PRESUPUESTO1"

Set ws = Sheets("ALTA PRESUPUESTO1") 'Hoja donde actua

Nom_Carpeta = ws.Range("K9").Value

Nom_SubCarpeta = ws.Range("B1").Value

****************************************************************

El nombre del libro nuevo es según celda ws.Range("B2") en la hoja con nombre "ALTA PRESUPUESTO1"

y en el libro nuevo, muevo o copio las hojas de la 40 hasta la ultima creada del libro con nombre  DESIGN DVACHQ222.xlsm.

Un Cordial Saludo

David.C

Te anexo la macro.

Sub CopiarHojas()
'Por.Dante Amor
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set h1 = Sheets("ALTA PRESUPUESTO1")
    '
    car1 = h1.Range("K9").Value
    car2 = h1.Range("B1").Value
    nomb = h1.Range("B2").Value
    ruta = "\MOZART\Presupuestos\HISTORIAL PRESUPUESTARIO DAVID CALLEJA 2014\XSWM01311\ALTA DE PRESUPUESTOS\"
    cad = ""
    numhojas = 40
    '
    If Dir(ruta, vbDirectory) = "" Then cad = "La ruta destino no existe. " & Chr(13)
    If car1 = "" Then cad = cad & "Nombre Carpeta Inválido." & Chr(13)
    If car2 = "" Then cad = cad & "Nombre SubCarpeta Inválido." & Chr(13)
    If nomb = "" Then cad = cad & "Nombre Archivo Inválido." & Chr(13)
    If Sheets.Count < numhojas Then cad = cad & "No hay hojas para copiar." & Chr(13)
    If cad <> "" Then
        MsgBox cad & "El archivo no se creará", vbCritical, "Error!!!"
        Exit Sub
    End If
    '
    If Dir(ruta & car1, vbDirectory) = "" Then
        MkDir ruta & car1
    End If
    If Dir(ruta & car1 & "\" & car2, vbDirectory) = "" Then
        MkDir ruta & car1 & "\" & car2
    End If
    '
    Dim hojas()
    n = 0
    For h = numhojas To Sheets.Count
        ReDim Preserve hojas(n)
        hojas(n) = Sheets(h).Name
        n = n + 1
    Next
    Sheets(hojas).Move
    ActiveWorkbook.SaveAs ruta & car1 & "\" & car2 & "\" & nomb & ".xlsx"
    ActiveWorkbook.Close
    '
    Application.ScreenUpdating = True
    MsgBox "Hojas copiadas", vbInformation
End Sub
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias

¡Gracias! Madre Mía eres Genio, muchas gracias y perdona las molestias ocasionadas, hasta la próxima.

Un Saludo

David.C

Una sola petición es que necesito la hoja 40 que además de moverla, también se me quede en el libro.

Al final de la respuesta te aparece un botón "Votada", presiona el botón; te aparecen 2 opciones "Excelente" y "Votar", puedes cambiar la valoración.

¡Gracias! 

Una sola petición Sr. Dante Amor, es que necesito la hoja 40 que además de moverla, también se me quede en el libro.

Si no valoras mis respuestas ya no te podré ayudar.

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas