Macro para crear vinculos en todas las hojas

Con esta macro creas automaticamente un menu con vinculos entre hojas.

De manera que ejecutando la macro y dándole una celda tenemos en un abrir y cerrar de ojos un menu en todas las hojas de nuestro archivo para moverte entre ellas

Código de la macro

Sub VinculosParaHojas()

Dim Rango As String
Dim NumeroHojas As Integer
Dim NombreHoja As String
Dim Vinculo As String
Dim i As Integer
Dim Y As Integer

On Error GoTo error

Rango = InputBox(«Escriba la celda a partir de donde quieres los vinculos:» _
& vbNewLine & «Ten en cuenta que a parir de esa celda los vinculos se crearan hacia abajo», «Excel y finanzas»)

If Rango = «» Then Exit Sub

NumeroHojas = ThisWorkbook.Sheets.Count

Sheets(1).Activate

For i = 1 To NumeroHojas

NombreHoja = Sheets(i).Name

If Range(Rango) = "" Then

    Range(Rango).Select
    Selection.Value = NombreHoja
    Vinculo = NombreHoja & "!a1"
    Selection.Hyperlinks.Add anchor:=Selection, Address:="", SubAddress:=Vinculo, ScreenTip:="Ir a", TextToDisplay:="ir a " & NombreHoja

ElseIf Range(Rango).Offset(1, 0) = "" Then

    Range(Rango).Offset(1, 0).Select
    Selection.Value = NombreHoja
    Vinculo = NombreHoja & "!a1"
    Selection.Hyperlinks.Add anchor:=Selection, Address:="", SubAddress:=Vinculo, ScreenTip:="Ir a", TextToDisplay:="ir a " & NombreHoja

Else

    Range(Rango).End(xlDown).Offset(1, 0).Select
    Selection.Value = NombreHoja
    Vinculo = NombreHoja & "!a1"
    Selection.Hyperlinks.Add anchor:=Selection, Address:="", SubAddress:=Vinculo, ScreenTip:="Ir a", TextToDisplay:="ir a " & NombreHoja

End If

Next i

Range(Rango).CurrentRegion.Copy

For Y = 2 To NumeroHojas

Sheets(Y).Range(Rango).PasteSpecial xlPasteAll

Next Y

Application.CutCopyMode = False
Sheets(1).Range(Rango).Select

Exit Sub

error:

MsgBox «El nombre de la celda no es válido, introduzca un valor de referencia como A1», vbCritical, «Excel y Finanzas»

End Sub

Como copiar y pegar el código

Como insertar una macro en la cinta de opciones personalizada