Microsoft 365 Lien hypertexte

[Chasse]

Bonsoir le Forum
En colonne B et sur 250 Lignes de la feuil1 j'ai les titres d'un roman
en feuil5 sur la ligne 1 sur 250 Colonnes j'ai un extrait de chaque roman.
Comment Puis-je changes ce code pour qu'il fonctionne

Sub Lien()
fin = Range("B" & Rows.Count).End(xlUp).Row
fin1 = 1
For i = 2 To fin
Cells(i, 2).Select
   ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _
    Feuil5.Cells(1, fin1)
    fini1 = fini1 + 1
Next
End Sub

Merci de votre aide et bonne soirée

 

[Dudu2]

Bonjour,

Sub Lien()
    Dim NbLignes As Long
    Dim i As Long
    
    With ThisWorkbook.Worksheets("Feuil1")
        'Défiltrer pour ne pas fausser le xlUp avec des lignes de fin filtrées
        If Not .AutoFilter Is Nothing Then .AutoFilter.ShowAllData
        NbLignes = .Cells(Rows.Count, 2).End(xlUp).Row
        
        For i = 2 To NbLignes
            .Cells(i, 2).Hyperlinks.Delete
            .Hyperlinks.Add Anchor:=.Cells(i, 2), Address:="", SubAddress:= _
                "Feuil5!" & .Cells(1, i - 1).Address
        Next i
    End With
End Sub

 

[Dudu2]

Et si tu veux le retour:

Sub Lien()
    Dim NbLignes As Long
    Dim i As Long
    
    With ThisWorkbook.Worksheets("Feuil1")
        'Défiltrer pour ne pas fausser le xlUp avec des lignes de fin filtrées
        If Not .AutoFilter Is Nothing Then .AutoFilter.ShowAllData
        NbLignes = .Cells(Rows.Count, 2).End(xlUp).Row
        
        For i = 2 To NbLignes
            .Cells(i, 2).Hyperlinks.Delete
            .Hyperlinks.Add Anchor:=.Cells(i, 2), Address:="", SubAddress:= _
                "Feuil5!" & .Cells(1, i - 1).Address
        Next i
    End With
    
    With ThisWorkbook.Worksheets("Feuil5")
        For i = 2 To NbLignes
            .Cells(1, i - 1).Hyperlinks.Delete
            .Hyperlinks.Add Anchor:=.Cells(1, i - 1), Address:="", SubAddress:= _
                "Feuil1!" & .Cells(i, 2).Address
                
            With .Cells(1, i - 1).Font
                .Underline = xlUnderlineStyleNone
                .ColorIndex = xlAutomatic
            End With
        Next i
    End With
End Sub

 

[Dudu2]

Et pour finir, si tu veux un code paramétré pour pouvoir changer facilement les éléments:

Sub Lien()
    Dim NbLignes As Long
    Dim i As Long

    'Paramètres de noms et de positions
    Const NomFeuilleTitres = "Feuil1"
    Const NomFeuilleExtraits = "Feuil5"
    Const NoColonneTitres = 2
    Const NoLigneExtraits = 1
    Const NbLignesTitreTitres = 1
    Const NbColonnesTitreExtraits = 0
   
    With ThisWorkbook.Worksheets(NomFeuilleTitres)
        'Défiltrer pour ne pas fausser le xlUp avec des lignes de fin filtrées
        If Not .AutoFilter Is Nothing Then .AutoFilter.ShowAllData
        NbLignes = .Cells(Rows.Count, NoColonneTitres).End(xlUp).Row
       
        For i = NbLignesTitreTitres + 1 To NbLignes
            .Cells(i, NoColonneTitres).Hyperlinks.Delete
            .Hyperlinks.Add Anchor:=.Cells(i, NoColonneTitres), Address:="", SubAddress:= _
                NomFeuilleExtraits & "!" & .Cells(NoLigneExtraits, i - NbLignesTitreTitres + NbColonnesTitreExtraits).Address
        Next i
    End With
   
    With ThisWorkbook.Worksheets(NomFeuilleExtraits)
        For i = NbLignesTitreTitres + 1 To NbLignes
            .Cells(NoLigneExtraits, i - NbLignesTitreTitres + NbColonnesTitreExtraits).Hyperlinks.Delete
            .Hyperlinks.Add Anchor:=.Cells(NoLigneExtraits, i - NbLignesTitreTitres + NbColonnesTitreExtraits), Address:="", SubAddress:= _
                NomFeuilleTitres & "!" & .Cells(i, NoColonneTitres).Address
               
            With .Cells(NoLigneExtraits, i - NbLignesTitreTitres + NbColonnesTitreExtraits).Font
                .Underline = xlUnderlineStyleNone
                .ColorIndex = xlAutomatic
            End With
        Next i
    End With
End Sub

 

[Chasse]

Et pour finir, si tu veux un code paramétré pour pouvoir changer facilement les éléments:

Sub Lien()
    Dim NbLignes As Long
    Dim i As Long

    'Paramètres de noms et de positions
    Const NomFeuilleTitres = "Feuil1"
    Const NomFeuilleExtraits = "Feuil5"
    Const NoColonneTitres = 2
    Const NoLigneExtraits = 1
    Const NbLignesTitreTitres = 1
    Const NbColonnesTitreExtraits = 0
  
    With ThisWorkbook.Worksheets(NomFeuilleTitres)
        'Défiltrer pour ne pas fausser le xlUp avec des lignes de fin filtrées
        If Not .AutoFilter Is Nothing Then .AutoFilter.ShowAllData
        NbLignes = .Cells(Rows.Count, NoColonneTitres).End(xlUp).Row
      
        For i = NbLignesTitreTitres + 1 To NbLignes
            .Cells(i, NoColonneTitres).Hyperlinks.Delete
            .Hyperlinks.Add Anchor:=.Cells(i, NoColonneTitres), Address:="", SubAddress:= _
                NomFeuilleExtraits & "!" & .Cells(NoLigneExtraits, i - NbLignesTitreTitres + NbColonnesTitreExtraits).Address
        Next i
    End With
  
    With ThisWorkbook.Worksheets(NomFeuilleExtraits)
        For i = NbLignesTitreTitres + 1 To NbLignes
            .Cells(NoLigneExtraits, i - NbLignesTitreTitres + NbColonnesTitreExtraits).Hyperlinks.Delete
            .Hyperlinks.Add Anchor:=.Cells(NoLigneExtraits, i - NbLignesTitreTitres + NbColonnesTitreExtraits), Address:="", SubAddress:= _
                NomFeuilleTitres & "!" & .Cells(i, NoColonneTitres).Address
              
            With .Cells(NoLigneExtraits, i - NbLignesTitreTitres + NbColonnesTitreExtraits).Font
                .Underline = xlUnderlineStyleNone
                .ColorIndex = xlAutomatic
            End With
        Next i
    End With
End Sub

 

[Chasse]

Bonsoir Dudu2
Merci pour ton aide. Super !
Je n'ai pas pu te répondre avant j'ai eu de la visite à l'improviste
Ta première réponse me va bien
Encore merci et bonne soirée