Crear hipervínculos con hojas del mismo libro
Tengo un libro en donde en la primera hoja tengo un indice de más o menos dos cientos elementos, e igual número de hojas. Necesito crear una macro que:
Busque en la columna "E" a partir de la celda "E5" y que también busque en todas las hojas del libro el mismo número que esta en la celda de la columna "E", cuando coincida el número de la celda y de la hoja que cree un hipervínculo entre las dos, es decir, si en la columna E existe un numero "1234" que cree un hipervínculo con la hoja "1234"; si ya existe el hipervínculo que no haga nada.
1 respuesta
. 27/09/16
Buenas tardes, Oscar
La siguiente rutina hace lo que solicitas.
Nota que, al principio del código, hay unas variables donde indicarás las direcciones que desees
Accede al Editor de VBA (Atajo: Alt + F11), inserta un módulo - si no tuvieras uno ya- y pega el siguiente código:
Sub PoneHyp() '---- Variables modificables: '=== OSCAR, modifica estos datos de acuerdo a tu proyecto: IniList = "E5" ' celda inicial donde están los nombres de las hojas a vincular CeldaIr = "B2" ' celda donde lleva cada hipervínculo '---- fin Variables ' '---- inicio de rutina: ' 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 End Sub
.
¡Gracias!
Era exactamente lo que necesitaba.
Un abrazo.
Oscar
.
Bien, Oscar!
Me alegro de que te haya servido.
Saludos
Fer
.
Hola Fernando,
Solicito nuevamente tu ayuda con este tema; tal vez me puedes ayudar como puedo hacer para que la macro se ejecute automáticamente al abrir el Documento.
Muchas gracias.
.
Hola, Oscar
Para que funcione como solicitas, activa el editor de Visual Basic (presiona Alt+F11) y en el panel de la izquierda busca la hoja que dice "ThisWorkbook" (o "EsteLibro" según la versión")
Copia el código siguiente y pégalo en el panel desplegado a la derecha:
Private Sub Workbook_Open() Ahoja = "INDICE" Sheets(Ahoja).Select PoneHyp End Sub
Luego cierra el Editor y graba el archivo.
Dado que la rutina anterior funciona sobre la hoja activa, este procedimiento te lleva primero a la hoja donde quieres los vínculos y luego ejecuta la rutina. Porque el archivo pudo haber sido grabado en otra hoja.
Modifica esa variable según tu caso y funcionará cada vez que abras el archivo.
Abrazo
Fer
.
Hola Fernando,
Nuevamente gracias, eso era lo que estaba buscando.
Una cosa más, tal vez me puedes ayudar con un tema más de esto. Necesito guardar este libro con el nombre que tiene con formato .xlsm, y también necesito guardar una copia de este libro en formato .xlsx que sea de solo lectura en otra carpeta.. Por favor me podrías ayudar con esto.
Gracias.
.
Buenas, Oscar
Acabo de notar que quedó pendiente esta otra pregunta.
Prueba con esta rutina que graba -primero- el archivo como está y luego su versión sin macro y de sólo lectura. Recuerda indicarle, dentro del código, la dirección de la carpeta de destino.
Sub GrabaX2() DirCopia = "C:\copiaArchivo" 'carpeta donde grabar la copia sin macros y de solo lectura. DirCopia = DirCopia & IIf(Right(DirCopia, 1) = "\", "", "\") NomArch = ActiveWorkbook.Name NomArch = Left(NomArch, InStr(1, NomArch, ".") - 1) ActiveWorkbook.Save Application.DisplayAlerts = False ActiveWorkbook.SaveAs DirCopia & NomArch & ".xlsx", xlOpenXMLWorkbook, , xlYes End Sub
Desde luego, al terminar esta macro, ya no estará disponible porque el cambio de tipo de archivo elimina todas las rutinas que tuviere.
Saludos
Fer
.
Hola Fernando,
Nuevamente gracias por tu ayuda. Al ejecutar el código que me enviaste permanece abierto el documento. Xlsx. Como podría hacer para que después que se ejecute el código permanezca abierto el archivo. Xlsm y se cree la copia en la ruta especificada.
De antemano gracias por tu ayuda.
Saludos
Oscar
.
Hola, Oscar
La siguiente variante graba ambos archivos y te deja en el original. También te avisa que ya lo hizo:
Sub GrabaX2() DirCopia = "C:\copiaArchivo" 'carpeta donde grabar la copia sin macros y de solo lectura. DirCopia = DirCopia & IIf(Right(DirCopia, 1) = "\", "", "\") NomArch = ActiveWorkbook.Name Carpeta = ActiveWorkbook.Path NomArchi = Left(NomArch, InStr(1, NomArch, ".") - 1) Application.ScreenUpdating = False ActiveWorkbook.Save 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
Espero que ahora sí esté como quieres.
Abrazo
Fer
.
Hola Fernando,
Cuando Ejecuto la Macro me sale un error 1004, "No se puede guardar este libro con el mismo nombre de otro libro o complemento abiertos. Elija un nombre distinto o cierre el otro libro o complemento antes de guardar". Por favor me puedes ayudar con este inconveniente.
Sub Grabar_X2 DirCopia = "C:\Users\z003bpca\Desktop\Bitacora\Nueva\" 'carpeta donde grabar la copia sin macros y de solo lectura. DirCopia = DirCopia & IIf(Right(DirCopia, 1) = "\", "", "\") NomArch = ActiveWorkbook.Name Carpeta = ActiveWorkbook.Path NomArchi = Left(NomArch, InStr(1, NomArch, ".") - 1) Application.ScreenUpdating = False ActiveWorkbook.Save 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
Muchas Gracias,
Un Abrazo.
Oscar
.
Buenas, Oscar
Por el mensaje que recibiste, puedo suponer que tenías abierto el archivo con extensión xlsx al ejecutar la rutina VBA. No es un problema de la rutina.
Asegurate de mantener en pantalla sólo el archivo xlsm y lanza de nuevo la macro.
Como verás al final del código, ya tiene una instrucción para cerrar el xlsx cuando fue generado.
En las pruebas que hice funcionó OK.
Intentalo y avísame cómo te fue.
Saludos
Fernando
.
Hola Fernando,
Lo volví a intentar pero no es posible, al momento que esta ejecutando la Macro se detiene en la siguiente línea :
ActiveWorkbook.SaveAs DirCopia & NomArchi & ".xlsx", xlOpenXMLWorkbook,, xlYes
Efectivamente al momento que sale el error los dos libros están abiertos; tanto el .xlsm y el .xlsx. No se si sea una solución guardar el nuevo libro .xlsx con otro nombre.
Muchas gracias por tu ayuda.
Un abrazo.
Oscar
.
Hola,
Casi que me inclinaría a pensar que se trató de un problema con el nombre de la carpeta que usaste, porque probé la macro varias veces sin recibir error.
Por ello, la siguiente variante incorpora un control de existencia de la carpeta que indicaste.
Si no la encuentra te avisará y, además, te dará la opción de crearla automáticamente, si lo deseas:
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)
Application.ScreenUpdating = False
ActiveWorkbook.Save
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
Una consideración muy importante, si la rutina dio error, cierra el archivo sin grabar y ábrelo de nuevo antes de ejecutar la macro nuevamente. Hacerlo luego del error puede llevar a más errores.
Un abrazo
Fer
.
Hola Fernando,
Muchas gracias nuevamente; puse el nuevo código que me enviaste; pero sigo teniendo problemas en la siguiente línea:
ActiveWorkbook.SaveAs DirCopia & NomArchi & ".xlsx", xlOpenXMLWorkbook,, xlYes
Realmente no se cual podría ser el problema, se detiene exactamente en esa línea, la parte de la carpeta no lo toma en cuenta para nada.
Mira dentro de esta mismo documento estoy ejecutando otra macro, no se si ese sea el problema. En general la macro completa queda así:
Private Sub Workbook_Open()
Call Copiar_adjuntos
Call Grabar_X2
End Sub
'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
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)
l2.Close False
Application.ScreenUpdating = True
'MsgBox "Copia realizada", vbInformation
End Sub
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)
Application.ScreenUpdating = False
ActiveWorkbook.Save
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 SubMuchas gracias nuevamente de antemano.
Un abrazo.
Oscar
.
Buenos días, Oscar
Noto que tu primera rutina Copiar_adjuntos abre un libro con extensión xls.
Luego, aparentemente, lo cierra. Pero puede ser que la segunda macro interprete que ese es el libro a guardar.
De todos modos antes de que finalice esa macro coloca esta instrucción:
L1. Activate
Para asegurarte de que GrabaX2 trabaje sobre el libro que lanzó la rutina.
No sé si funcionará -en mi equipo lo hace correctamente- pero como es una práctica recomendada para ahorrar memoria de MS Excel, por cada Set xxx = yyy. deberías colocar al final un Set xxx = Nothing.
Es decir que, luego de la instrucción que te recomendé, vacía las posiciones de memoria con
Set l1 = Nothing
Set l2 = Nothing
etc...
Finalmente, si aún así tienes problemas, cuando la rutina se detenga en esa línea, elige Depurar y acerca el puntero del mouse a las variables DirCopia y NomArchi. Te aparecerá un comentario con el contenido que tienen en ese momento. Verifica que sean los correctos o envíamelos en otro post aqui.
Ojalá algo de esto sirva para detectar qué pasa en tu equipo (y que no pasa en el mio).
Abrazo
Fer
.
Hola Fernando,
Nuevamente gracias por tu ayuda; mira ya coloque las instrucciones que me indicaste:
Private Sub Workbook_Open()
Call Copiar_adjuntos
Call Grabar_X2
End Sub
'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
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)
l2.Close False
l1.Activate
Set l1 = Nothing
Set l2 = Nothing
Application.ScreenUpdating = True
'MsgBox "Copia realizada", vbInformation
End Sub
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)
Application.ScreenUpdating = False
ActiveWorkbook.Save
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 SubPero el problema sigue en la misma linea:
ActiveWorkbook.SaveAs DirCopia & NomArchi & ".xlsx", xlOpenXMLWorkbook,, xlYes
Los comentarios de la línea en las variables:
DirCopia: DirCopia = "C:\Users\z003bpca\Desktop\Bitacora\Nueva\".
NomArchi= "Bitacora CT"
En este caso es la carpeta donde se va a guardar el nuevo archivo .xlsx es correcto y el nombre del archivo es el mismo del nombre original.
Realmente no se cual podría ser el error en este caso. Te agradezco mucho tu ayuda.
Un abrazo.
Oscar
.
Buenas, Oscar
Sigue siendo un misterio que me funcione a mi y no a ti.
Me interesa saber por qué no lo hace.
Por ello te paso esta nueva versión del mismo procedimiento al cual le agregué una instrucción que atrape el error concreto que surge.
Entonces, reemplaza la rutina anterior con esta. Graba el archivo. Cierre MS Excel y abrelo de nuevo.
Recién entonces ejecuta este procedimiento y, de producirse el error, debería aparecerte un mensaje con la descripción del error.
Sub Grabar_X2()
DirCopia = "C:\2mails"
'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)
Application.ScreenUpdating = False
ActiveWorkbook.Save
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.SaveAs DirCopia & NomArchi & ".xlsx", xlOpenXMLWorkbook, , xlYes
If Err.Number <> 0 Then
MsgBox "El error es: " & Chr(10) & Err.Description, vbInformation, "OSCAR, anota y pásame lo que diga esta ventana:"
Else
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 If
End SubVeamos qué pasa con esto.
Abrazo
Fer
.
Hola Fernando,
Realmente te agradezco mucho por tu interés en ayudarme. Ya copie la nueva rutina que tu me enviaste y cuando la ejecuto me sale lo siguiente: " El error es: No se puede guardar el libro con el mismo nombre de un libro o otro complementos abiertos. Elija un nombre distinto o cierre el otro libro o complementos antes de guardar."
Le doy aceptar el error y me aparece el siguiente mensaje: "Este archivo y la copia de seguridad Bitacora Ct.xlsx en C:\Users\z003bpca\Desktop\Bitacora\Nueva acaban de grabarse." Cuando le doy aceptar al mensaje se cierra el documento .xlsx y permanece abierto el documento original; ademas se guarda la copia en la carpeta indicada.
Tal vez si lo cambiamos de nombre al nuevo documento que esta generando lo puedo solucionar?,
Un fuerte abrazo.
Oscar
.
Hola, Oscar
Efectivamente, pese a que la rutina indica grabar con otra extensión, para tu versión de MS Excel considera sólo el nombre del archivo y, por tanto, entiende que está intentando guardar como con el mismo nombre del archivo abierto.
Por ello, no habrá más remedio que darle un nombre distinto.
La rutina siguiente agrega al nombre del archivo de copia "_Bck", por back up. Pero puedes reemplazarlo por la terminación que desees:
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 SubOjalá que con esto tengas lo que buscabas o algo parecido.
Pensar que esta pregunta empezó con una rutina para agregar hipervínculos y terminó en esto.
Pero bueno, lo único importante es que tengas funcionando tu proyecto.
Un abrazo
Fer
.
¡Gracias!
Fernando,
De verdad muchas gracias por ayudarme en este tema. Realmente soy muy novato en el tema de visual basic.
Necesito una ayuda con un código que tengo. Sera que tu me puedes ayudar?
Si tu respuesta es afirmativa, lo puedo poner acá o creo una pregunta nueva dirigida a ti?.
Un abrazo
Oscar
.
Ok, Oscar
Puedes consultarme, cuando gustes.
Por una cuestión de prolijidad, te diría que cierres esta pregunta que tiene tres temas distintos y empecemos una nueva.
Pero no me dijiste si la última rutina finalmente te funcionó.
Un abrazo
Fer
.
Hola Fernando,
Muchas gracias, sabes que al final a pesar que le cambio el nombre me sigue saliendo el mismo error.
En el código anterior en el mensaje, simplemente le puse una " ' " para que los mensajes de error no aparezcan. Con esto pasa directamente y guarda los dos archivos y no presenta ningún mensaje.
Ahora el problema es que cuando copia la información de la macro Copiar_adjuntos lo copia dos veces. Realmente no se cual pueda ser el problema.
Te paso la macro completa que estoy utilizando en el libro a ver si talvez tu puedes ayudarme con ese problema.
Nuevamente muchas gracias.
Un abrazo
Oscar
Private Sub Workbook_Open()
Call Copiar_adjuntos
Ahoja = "INDICE"
Sheets(Ahoja).Select
PoneHyp
Call Grabar_X2
End Sub
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
End Sub
'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
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)
l2.Close False
Application.ScreenUpdating = True
'MsgBox "Copia realizada", vbInformation
End Sub
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)
Application.ScreenUpdating = False
ActiveWorkbook.Save
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.SaveAs DirCopia & NomArchi & ".xlsx", xlOpenXMLWorkbook, , xlYes
If Err.Number <> 0 Then
'MsgBox "El error es: " & Chr(10) & Err.Description, vbInformation, "OSCAR, anota y pásame lo que diga esta ventana:"
Else
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 If
End Sub
.
Disculpa Oscar
Recién noto este pendiente
Dos cosas.
1.- La rutina Grabar_X2 que veo en esta última pregunta no es la misma que te había enviado.
2. Si estas rutinas que pasaste van a ejecutarse al abrir el libro como veo, esos códigos deben estar en un módulo aparte.
Es decir, prueba dejando en ThisWorkbook:
Private Sub Workbook_Open() Call Copiar_adjuntos Ahoja = "INDICE" Sheets(Ahoja).Select PoneHyp Call Grabar_X2 End Sub
E inserta un módulo (insertar - modulo) aparte, lo siguiente:
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
End Sub
'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
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)
l2.Close False
Application.ScreenUpdating = True
'MsgBox "Copia realizada", vbInformation
End Sub
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
Esta última es la que te había pasado antes.
Debería funcionar OK.
Un abrazo
Fer
.
¡Gracias!
Hola Fernando,
Muchas gracias, exactamente funciona perfecto,
Un abrazo.
Oscar
.
Efectivamente, el comportamiento de las rutinas colocadas en el ThisWorkbooks o en cada hoja suele arrojar errores o tener comportamientos erráticos. Por eso conviene colocar las rutinas en módulos y llamarlas desde esos apartados.
Abrazo
Fer
.
