Contar hojas con array y mover nuevo libro vba
Porque no me ayudan, 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
Te anexo la macro actualizada para mover las hojas de la 40 en adelante y dejando la hoja 40 en el libro original.
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\"
ruta = "C:\trabajo\"
cad = ""
numhojas = 5 '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
Set l1 = ThisWorkbook
Set l2 = ActiveWorkbook
l2.Sheets(1).Copy after:=l1.Sheets(l1.Sheets.Count)
l2.SaveAs ruta & car1 & "\" & car2 & "\" & nomb & ".xlsx"
l2.Close
'
Application.ScreenUpdating = True
MsgBox "Hojas copiadas", vbInformation
End Sub'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
