Macro que se ejecuta automáticamente al abrir, cerrar después de ejecutar procesos.
fejoal
Hola Fernando,
Espero que te encuentres bien, solicito tu ayuda con el código que vienes ayudándome. El código esta trabajando bien. Mi pregunta es la siguiente, ¿las macros que tengo en ese libro pueden ejecutarse sin abrir el libro?; si no es así cual seria la rutina para que después que haga todo lo que necesito se cierren los dos libros el archivo .xlsm y la copia .xlsx.
El libro esta organizado de la siguiente forma:
Private Sub Workbook_Open() Call Grabar_X2 Call Copiar_adjuntos Ahoja = "INDICE" Sheets(Ahoja).Select PoneHyp End Sub
Modulo 1:
'Copiar informacion de Reporte a Bitacora
Sub Copiar_adjuntos()
Application.ScreenUpdating = False
Set l1 = ThisWorkbook
Ruta = "C:\Users\z003bpca\Desktop\Bitacora\"
arch = "copy_Reporte.xls"
If Dir(Ruta & arch) = "" Then
MsgBox "El archivo Reporte no existe en la ruta", vbCritical
Exit Sub
End If
'
Set l2 = Workbooks.Open(Ruta & arch)
Set h2 = l2.Sheets("Sheet0")
Num = h2.Range("D5").Text
If Num = "" Then
MsgBox "La celda D5 no contiene datos", vbExclamation
l2.Close False
Exit Sub
End If
If IsNumeric(Num) Then
Num = "" & Val(Num)
End If
'
existe = False
For Each h In l1.Sheets
If h.Name = Num Then
existe = True
Set h1 = h
Exit For
End If
Next
'
If existe = False Then
l1.Sheets.Add after:=l1.Sheets(l1.Sheets.Count)
Set h1 = l1.ActiveSheet
'copia de columna A de Hoja Datos
Sheets("Datos").Visible = True
Sheets("Datos").Columns("A").Copy h1.Columns("A")
Sheets("Datos").Visible = False
h1.Name = Num
End If
'
uc = h1.Cells(1, Columns.Count).End(xlToLeft).Column + 1
If uc < Columns("B").Column Then uc = Columns("B").Column
h2.Range("O42:O99").Copy h1.Cells(1, uc)
'ajusta columnas de B en adelante a 40
h1.Columns.ColumnWidth = 40
h1.Columns("A:A").EntireColumn.AutoFit
l2.Close False
Application.ScreenUpdating = True
'MsgBox "Copia realizada", vbInformation
End SubModulo 2:
Sub PoneHyp() IniList = "E5" ' celda inicial donde están los nombres de las hojas a vincular CeldaIr = "B2" ' celda donde lleva cada hipervínculo For fila = 0 To Range(IniList).CurrentRegion.Rows.Count - 1 vinc = Range(IniList).Offset(fila).Value On Error Resume Next Set SheetEx = ActiveWorkbook.Sheets(CStr(vinc)) If Err = 0 Then vinc = "'" & vinc & "'!" & CeldaIr ActiveSheet.Hyperlinks.Add Anchor:=Range(IniList).Offset(fila), Address:="", SubAddress:=vinc End If Err.Clear On Error GoTo 0 Set SheetEx = Nothing Next ActiveWorkbook.Save End Sub
Modulo 3:
Sub Grabar_X2()
DirCopia = "C:\Users\z003bpca\Desktop\Bitacora\Nueva\" 'carpeta donde grabar la copia sin macros y de solo lectura.
'control de existencia de carpeta
On Error Resume Next
ChDir DirCopia
If Err = 76 Then
QueHago = MsgBox("la carpeta " & DirCopia & " NO existe." & Chr(10) & "¿La creo?", vbOKCancel, "NO ESTA ¿QUE HAGO?")
If QueHago = 1 Then
MkDir DirCopia
Else
Exit Sub
End If
End If
Err.Clear
On Error GoTo 0
DirCopia = DirCopia & IIf(Right(DirCopia, 1) = "\", "", "\")
NomArch = ActiveWorkbook.Name
Carpeta = ActiveWorkbook.Path
NomArchi = Left(NomArch, InStr(1, NomArch, ".") - 1) & "_Bck"
Application.ScreenUpdating = False
ActiveWorkbook.Save
Application.Wait (Now + TimeValue("00:00:03"))
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs DirCopia & NomArchi & ".xlsx", xlOpenXMLWorkbook, , xlYes
Workbooks.Open Carpeta & "\" & NomArch
Application.ScreenUpdating = True
Application.ScreenUpdating = False
Windows(NomArchi & ".xlsx").Activate
ElMensaje = "Este archivo y la copia de seguridad " & Chr(10) & NomArchi & ".xlsx" & " en " & DirCopia & Chr(10) & "acaban de grabarse."
TipoMens = vbInformation
ElTitulo = "ARCHIVOS GRABADOS"
MsgBox ElMensaje, TipoMens, ElTitulo
Application.ScreenUpdating = True
Application.DisplayAlerts = True
ActiveWorkbook.Close
End Sub
1 respuesta más de otro experto
.
Buenas, Oscar
Necesariamente deberás abrir el libro para que se ejecute.
De todos modos, ya que -al abrirse- dispara esas rutinas puedes agregarle una linea para que lo cierre sin grabar, pues probablemente ya lo hizo alguna de las rutinas que se ejecutaron.
Sólo ten en cuenta que puede llegar a haber alguna detención cuando muestra los cuadros de diálogo para que tomes una acción cuando se topa con algún inconveniente.
Para que se cierre solo agrega, al final de la rutina autoejecutable, una instrucción ActiveWorkbook. Close xlNo
Quedaría así:
Private Sub Workbook_Open() Call Grabar_X2 Call Copiar_adjuntos Ahoja = "INDICE" Sheets(Ahoja).Select PoneHyp ActiveWorkbook. Close xlNo End Sub
Un abrazo
Fer
.
Hola Fernando,
Gracias por tu ayuda, la línea que me indicas cierra el libro actual es decir el libro .xlsm; pero deja abierta el libro o la copia .xlsx; como puedo hacer apra que se cierren los dos.
Un abrazo.
Oscar
.
Es raro, porque la rutina que te compartí cierra ese archivo. Tal vez deberías cambiar el orden en que se ejecuten la rutinas al abrir
Algo así como esto:
Private Sub Workbook_Open() Call Copiar_adjuntos Ahoja = "INDICE" Sheets(Ahoja).Select PoneHyp Call Grabar_X2 ActiveWorkbook. Close xlNo End Sub
Deberías chequear si hace lo mismo que pretendes.
Saludos
Fernando
.
Hola Fernando,
Cambie el orden de las instrucciones como me indicas, cumple el objetivo la macros, pero aun así mantiene abierto el archivo .xlsx
Saludos
Oscar
.
Y si duplicas la ultima instrucción...
Private Sub Workbook_Open() Call Copiar_adjuntos Ahoja = "INDICE" Sheets(Ahoja).Select PoneHyp Call Grabar_X2 ActiveWorkbook. Close xlNo On Error Resume Next ActiveWorkbook.Close xlNo On Error GoTo 0 End Sub
Si no hubiera otros archivos debería cerrar ambos.
Saludos
Fer
.
Hola Fernando,
No se cual es el problema pero después que se ejecuta permanece abierto el archivo. xlsx. Sospecho que es problema de mi computador o mi office; el día de mañana lo intentare en otro equipo y probare si me funciona.
De igual manera muchas gracias por tu ayuda
.
Sí, tienes razón.
No parece haber razón para que siga abierto.
Prueba mañana y dime.
Saludos
Fernando
.