Iniciar sesiónCerrar
Correo:
Contraseña:
Entrar
Recordar sesión en este navegador
Iniciar sesiónIniciar sesiónCrear cuentaCrear cuenta
LWP » Foros » Excel » Macro para guardar hoja en otro libro

Excel - Macro para guardar hoja en otro libro

Volver
Nuevo Tema
<<>>
 
Vista:
Mensajes realizados anteriormente (No estaban la última vez que entraste)Macro para guardar hoja en otro libro
JOSE LUIS (09/06/2019 15:48:20)129 visitas
2 respuestas
Mensajes realizados anteriormente (No estaban la última vez que entraste)(+1)Macro para guardar hoja en otro libro
Antoni Masana (10/06/2019 09:55:31)
Mensajes realizados anteriormente (No estaban la última vez que entraste)Macro para guardar hoja en otro libro
JOSE LUIS (14/06/2019 14:55:00)
Imágen de perfil de JOSE LUIS
Val: 108
Ha disminuido su posición en 3 puestos en Excel (en relación al último mes)
Gráfica de Excel

Macro para guardar hoja en otro libro

Publicado por JOSE LUIS (51 intervenciones) el 09/06/2019 15:48:20
Buenos días a los integrantes de este prestigioso foro, esta ocasión recurro a uds para que me ayuden con una macro o quizás mejorarla, la idea que tengo es extraer toda la información (conservando su formato) de la pestaña CONSOLIDADO y que se guarde automáticamente en la carpeta donde se está trabajando, el nombre del archivo que se extrae esta en hoja PLANILLA celda D2, fecha y hora y con la extensión “.xlsx” (CONSOLIDADO CYPRESS ARROW2 2-5-2019 18-20-56 HRS.xlsx), como se aprecia en la macro que describe a continuación.

Adjunto link de archivo.

https://drive.google.com/file/d/1_SVxDlLOyuGGmpIih5d-M4wYJSm6S7La/view

Modulo 5:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
Sub GuardarComo30072015()
 
Dim ncorr As String
With Application
.ScreenUpdating = False
 
NOMBRE = ThisWorkbook.Name
carpeta = ThisWorkbook.Path
filaa = carpeta & "\" & NOMBRE
 
ncorr = Format(Hoja1.Range("D2").Value, "000")
 
A = " " & Day(Date) & "-" & Month(Date) & "-" & Year(Date) & " " & Hour(Time) & "-" & Minute(Time) & "-" & Second(Time) & " HRS"
 
.DisplayAlerts = False
.EnableEvents = False
If nombrar = vbYes Then
    filab = carpeta & "\" & "plantilla electronica1"
    ActiveWorkbook.SaveAs Filename:=filab, FileFormat:=xlOpenXMLWorkbookMacroEnabled
 
Else
        filab = carpeta & "\" & "CONSOLIDADO " & ncorr & UCase(titulo) & A
        Call Elimina_hojas
        ActiveWorkbook.SaveAs Filename:=filab, FileFormat:=xlOpenXMLWorkbookMacroEnabled
        ActiveWorkbook.Close
End If
.EnableEvents = True
.DisplayAlerts = True
 
xnombre = ActiveWorkbook.Name
Workbooks.Open filaa
vuf = Range("B" & Rows.Count).End(xlUp).Row
Range("B8:AQ" & vuf).ClearContents
Workbooks(xnombre).Close
 
.ScreenUpdating = True
End With
 
End Sub
 
Sub Elimina_hojas()
Dim Vec, Elim, ws As Worksheet
'

Vec = Array("PLANILLA", "RESUMEN", "BOLETA", "CONSOLIDADO", "DATA", "EXPORTA", "REPORTE BOLETAS", "TELECREDITO JUDICIAL", "TELECREDITO", "DESCUENTO", "MENU", "SORT", "NAVI", "RECIBO", "TABLA AFP") ' Estas son las hojas que se mantienen.

'

ReDim Elim(0 To 0)
For Each ws In Worksheets
  If IsError(Application.Match(ws.Name, Vec, 0)) Then
    ReDim Preserve Elim(1 To 1 + UBound(Elim)): Elim(UBound(Elim)) = ws.Name
  End If
Next
 
Application.DisplayAlerts = False: On Error Resume Next
  Worksheets(Elim).Delete
On Error GoTo 0: Application.DisplayAlerts = True
MsgBox "Finalizando....."
Sheets("MENU").Activate
Range("B8").Select
End Sub

Desde ya agradezco su apoyo y colaboración
Valora esta pregunta
Me gusta: Está pregunta es útil y esta claraNo me gusta: Está pregunta no esta clara o no es útil
0
Responder
Imágen de perfil de Antoni Masana
Val: 3.758
Plata
Ha mantenido su posición en Excel (en relación al último mes)
Gráfica de Excel

Macro para guardar hoja en otro libro

Publicado por Antoni Masana (1218 intervenciones) el 10/06/2019 09:55:31
Te pongo un par de mejoras y una critica

Mejora 1: el formato, cuando he visto el código creía que solo era UN proceso y son DOS que ahora se identifican mejor
Mejora 2: La línea en negrita.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
Sub GuardarComo30072015()
    Dim ncorr As String
    With Application
        .ScreenUpdating = False
 
        NOMBRE = ThisWorkbook.Name
        carpeta = ThisWorkbook.Path
        filaa = carpeta & "\" & NOMBRE
 
        ncorr = Format(Hoja1.Range("D2")?.Value, "000")
 
        A = " " & Format(Date, "dd-mm-yyyy") & " " & Format(Time, "hh-mm-ss") & " HRS"
 
        .DisplayAlerts = False
        .EnableEvents = False
        If nombrar = vbYes Then
            filab = carpeta & "\" & "plantilla electronica1"
            ActiveWorkbook.SaveAs Filename:=filab, FileFormat:=xlOpenXMLWorkbookMacroEnabled
 
        Else
            filab = carpeta & "\" & "CONSOLIDADO " & ncorr & UCase(titulo) & A
            Call Elimina_hojas
            ActiveWorkbook.SaveAs Filename:=filab, FileFormat:=xlOpenXMLWorkbookMacroEnabled
            ActiveWorkbook.Close
        End If
        .EnableEvents = True
        .DisplayAlerts = True
 
        xnombre = ActiveWorkbook.Name
        Workbooks.Open filaa
        vuf = Range("B" & Rows.Count).End(xlUp).Row
        Range("B8:AQ" & vuf).ClearContents
        Workbooks(xnombre).Close
 
        .ScreenUpdating = True
    End With
End Sub
 
Sub Elimina_hojas()
    Dim Vec, Elim, ws As Worksheet
    '

    ' Estas son las hojas que se mantienen.

    Vec = Array("PLANILLA", "RESUMEN", "BOLETA", "CONSOLIDADO", "DATA", "EXPORTA", _
                "REPORTE BOLETAS", "TELECREDITO JUDICIAL", "TELECREDITO", "DESCUENTO", _
                "MENU", "SORT", "NAVI", "RECIBO", "TABLA AFP")
    '

    ReDim Elim(0 To 0)
    For Each ws In Worksheets
        If IsError(Application.Match(ws.Name, Vec, 0)) Then
            ReDim Preserve Elim(1 To 1 + UBound(Elim)): Elim(UBound(Elim)) = ws.Name
        End If
    Next
 
    Application.DisplayAlerts = False:
    On Error Resume Next: Worksheets(Elim).Delete
    On Error GoTo 0
    Application.DisplayAlerts = True
    MsgBox "Finalizando....."
    Sheets("MENU").Activate
    Range("").Select
End Sub

El delete (marcado en negrita) hay que verificar que exista lo que se quiere borrar. Utilizar el On Error es chapucero y en este caso no le veo la necesidad y si sale error es porque algo se está haciendo mal.


Saludos.
\\//_
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
1
Comentar
Imágen de perfil de JOSE LUIS
Val: 108
Ha disminuido su posición en 3 puestos en Excel (en relación al último mes)
Gráfica de Excel

Macro para guardar hoja en otro libro

Publicado por JOSE LUIS (51 intervenciones) el 14/06/2019 14:55:00
Buenos días Antoni Masana, gracia por la mejora a la macro que tenia, la cual me ayudo mucho a ver el error que tenia, por lo que daria como TEMA SOLUCIONADO.

Gracias.
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar
Revisar política de publicidad