XL 2016 Recopier lien hypertexte en fonction d'une récupération de texte

[christ77000]

Bonjour, dans cette macro je récupère du texte venant de 5 autres feuilles sur deux critères, le mois en cours et le type de texte que je recopie dans une feuille commune (menu) . Ma demande dans les 5 feuilles il y a sur certaine ligne des liens hypertexte, comment les reprendre en même temps que le reste. Merci pour votre aide.

Sub TFParMois()
'---macro qui transfert dans l'onglet "Menu" tous les TF()du mois en cours---
Application.ScreenUpdating = False '---cacher les actions de la macro---

Dim Rg As Range
Dim NomFeuil As String
Dim i As Integer
Dim NumMois As Integer

NumMois = Sheets("Menu").Range("P24")
Call Retirer_la_protection
Range("J3:L32").ClearContents

For i = 1 To 5
NomFeuil = Sheets("Menu").Range("E" & i + 34) '---copie en fonction des onglets IT6---

    If Not Sheets(NomFeuil) Is Nothing Then
        Sheets(NomFeuil).Unprotect "toto" '---retirer la protection de ces feuilles---
        For Each Rg In Sheets(NomFeuil).Range("B18:B57") '---recherche du mois dans cette colonne 
            If Month(Rg.Value) = NumMois And Left(Rg.Offset(0, 5), 2) = "TF" Then --- récupération par type, ici commence par TF
                                  
                Sheets("Menu").Range("J32").End(xlUp).Offset(1, 0) = Rg.Offset(0, 5)
                Sheets("Menu").Range("J32").End(xlUp).Offset(0, 1) = Rg.Offset(0, 2) 'Paste 'End(xlUp).PasteSpecial xlPasteAll
                Sheets("Menu").Range("J32").End(xlUp).Offset(0, 2) = Left(NomFeuil, 2)
            
            End If
        Next
    End If
                
                Sheets(NomFeuil).Protect "toto" '---protection des feuilles IT6---
        Next
        Sheets("Menu").Select
                Sheets("Menu").Protect "toto"
          Application.ScreenUpdating = True '---voir les actions de la macro---
End Sub

 

[Rouge]

Bonjour,

Pour récupérer les liens hypertextes,
Exemple: le lien hypertexte est en cellule A1 de la feuille 2 et on veut le récupérer en cellule A1 de la feuille 1

With Sheets("Feuil1")
    If .Cells(1, "A").Hyperlinks.Count > 0 Then .Hyperlinks.Add .Range("A1"), Sheets("Feuil2").Range("A1")
End With

A adapter à votre fichier
Cdlt

 

[job75]

Bonjour christ77000, Rouge,

Avec la méthode cel1.Copy cel2 on copie tout y compris le lien hypertexte.

A+

 

[christ77000]

Bonjour et merci à tous les deux pour votre aide. Je viens de faire quelques tests mais je n'arrive pas a adapter vos codes sur mon code, je suis un débutant en VBA.

 

[christ77000]

j'ai modifier cette ligne
Sheets("Menu").Range("J32").End(xlUp).Offset(0, 1) = cel1.Copy.Rg.Offset(0, 2) mais ca plante dessus

 

[job75]

Allons allons, cel1 et cel2 c'était pour vous donner la méthode :

Rg.Offset(0, 2).Copy Sheets("Menu").Range("J32").End(xlUp).Offset(0, 1)

 

[christ77000]

Merci fonctionne impect. il m'en reste encore a appendre . Bon Week end a tous les deux.