Macro para crear nuevos archivos, no me funciona
Los expertos,
Les escribo pidiendoles ayuda. Tengo una macro que copia varias hojas de un archivo como valores en un archivo nuevo, y lo guarda.. La macro me ha funcionado bien hasta ahora que no corre, se queda cargando pero no corre nunca.. Cuando corro con el paso a paso creo identificar que el error es al crear el arreglo con Sheets(Array(p1, p2, p3, p4, p5, p6, p7)). Copy
Les pido colaboración.. El código está así:
Sub ResumenBasedeclientes_1Imagen_Haga_clic_en()
p1 = "a"
p2 = "b"
p3 = "c"
p4 = "d"
p5 = "e"
p6 = "f"
p7 = "g"
nombre = [A1]
ruta = [B1]
'
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Sheets(Array(p1, p2, p3, p4, p5, p6, p7)).Copy
Sheets(p1).Cells.Copy
Sheets(p1).Range("A1").PasteSpecial Paste:=xlPasteValues
Sheets(p2).Cells.Copy
Sheets(p2).Range("A1").PasteSpecial Paste:=xlPasteValues
Sheets(p3).Cells.Copy
Sheets(p3).Range("A1").PasteSpecial Paste:=xlPasteValues
Sheets(p4).Cells.Copy
Sheets(p4).Range("A1").PasteSpecial Paste:=xlPasteValues
Sheets(p5).Cells.Copy
Sheets(p5).Range("A1").PasteSpecial Paste:=xlPasteValues
Sheets(p6).Cells.Copy
Sheets(p6).Range("A1").PasteSpecial Paste:=xlPasteValues
Sheets(p7).Cells.Copy
Sheets(p7).Range("A1").PasteSpecial Paste:=xlPasteValues
ActiveWorkbook.SaveAs ruta & nombre & ".xlsx"
ActiveWorkbook.Close False
MsgBox "Archivo guardado", vbInformation
End Sub
1 Respuesta
Prueba con lo siguiente:
Sub ResumenBasedeclientes_1Imagen_Haga_clic_en()
p1 = "a"
p2 = "b"
p3 = "c"
p4 = "d"
p5 = "e"
p6 = "f"
p7 = "g"
'
Set l1 = ThisWorkbook
nombre = [A1]
ruta = [B1]
'
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Sheets(Array(p1, p2, p3, p4, p5, p6, p7)).Copy
Sheets(p1).Copy
Set l2 = ActiveWorkbook
l2.Sheets(p1).Cells.Copy
l2.Sheets(p1).Range("A1").PasteSpecial Paste:=xlPasteValues
'
l1.Sheets(p2).Copy after:=l2.Sheets(l2.Sheets.Count)
l2.Sheets(p2).Cells.Copy
l2.Sheets(p2).Range("A1").PasteSpecial Paste:=xlPasteValues
'
l1.Sheets(p3).Copy after:=l2.Sheets(l2.Sheets.Count)
l2.Sheets(p3).Cells.Copy
l2.Sheets(p3).Range("A1").PasteSpecial Paste:=xlPasteValues
'
l1.Sheets(p4).Copy after:=l2.Sheets(l2.Sheets.Count)
l2.Sheets(p4).Cells.Copy
l2.Sheets(p4).Range("A1").PasteSpecial Paste:=xlPasteValues
'
l1.Sheets(p5).Copy after:=l2.Sheets(l2.Sheets.Count)
l2.Sheets(p5).Cells.Copy
l2.Sheets(p5).Range("A1").PasteSpecial Paste:=xlPasteValues
'
l1.Sheets(p6).Copy after:=l2.Sheets(l2.Sheets.Count)
l2.Sheets(p6).Cells.Copy
l2.Sheets(p6).Range("A1").PasteSpecial Paste:=xlPasteValues
'
l1.Sheets(p7).Copy after:=l2.Sheets(l2.Sheets.Count)
l2.Sheets(p7).Cells.Copy
l2.Sheets(p7).Range("A1").PasteSpecial Paste:=xlPasteValues
'
ActiveWorkbook.SaveAs ruta & nombre & ".xlsx"
ActiveWorkbook.Close False
MsgBox "Archivo guardado", vbInformation
End SubSaludos.Dante Amor
Si es lo que necesitas.
Muchas gracias por tu ayuda Dante, sin embargo me aparece sub indice fuera del intervalo cuando copia la ultima hoja, como lo puedo arreglar??
Muchas gracias
Debes revisar que tengas 7 hojas con los nombres a, b, c, d, e, f y g . Si no tienes una de las hojas entonces borra las instrucciones, por ejemplo si no tienes la hoja "g", entonces borra estas instrucciones
l1.Sheets(p7).Copy after:=l2.Sheets(l2.Sheets.Count)
L2. Sheets(p7). Cells. Copy
L2. Sheets(p7). Range("A1"). PasteSpecial Paste:=xlPasteValuesOtra opción, es que al principio de la macro pongas esta instrucción
On Error Resume Next
