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

Respuesta
1

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 Sub

Saludos.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:=xlPasteValues

Otra opción, es que al principio de la macro pongas esta instrucción

On Error Resume Next

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas