Links (enlace) entre libros de excel
He creado un menú en excel con la intención de desplazarme entre libros, pero no me sale.
Help! ¿Alguien puede ayudarme con el tema?
2 respuestas
Esto te puede servir
Sub hiperlinkfichero()
'On Error Resume Next
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim path1 As String, ruta As String, texhipv As String
Set a = Sheets(ActiveSheet.Name)
uf = a.Range("A" & Rows.Count).End(xlUp).Row
path1 = ActiveWorkbook.Path
Set fso = CreateObject("Scripting.FileSystemObject")
Set carpeta = fso.getfolder(path1)
Set ficheros = carpeta.Files
NunFich = 0
For Each ficheros In ficheros
b = ficheros.Name
esp = InStr(b, " ")
nomfic = Val(Left(b, esp))
lug = InStr(b, ".")
ext = Mid(b, lug + 1)
If ext <> "xlsm" Then GoTo sigue:
busco = nomfic
Set codigo = a.Range("A5:A" & uf).Find(busco, LookIn:=xlValues, LookAt:=xlWhole)
If Not codigo Is Nothing Then
ruta = path1 & "\" & b
'a.Range("F" & codigo.Row) = ruta 'LA se escribia en la columna F pero es un dato innecesario por eso se eliminó coluna F, si se requiere agregar insertar columna F
texhipv = a.Range("A" & codigo.Row)
dire = codigo.Row
a.Hyperlinks.Add Anchor:=a.Range("A" & dire), Address:=ruta, TextToDisplay:=texhipv
NunFich = NunFich + 1
End If
sigue:
Next ficheros
Set carpeta = Nothing
Set ficheros = Nothing
MsgBox ("Se encontraron " & NunFich & " ficheros en la carpteta seleccionada"), vbInformation, "AVISO"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Suscribe https://youtube.com/programarexcel y recibirás en tu mail todas las actualizaciones