Création de lien hypertexte avec des particularités

Bonjour,

Je suis demandeur d'aide pour réaliser un code VBA, la création automatique de lien hypertexte en fonction de:

1: Les liens seront en accord avec le texte dans la cellule qui se réfère a une partie du nom du fichier (ex: dans la cellule j'ai "T3669-02M-104" et le fichier se nomme "Matrice_t3669-02M-104.drw.5")

Ils devront se créé automatiquement suivant une plage de sélection.

2: Le lien hypertexte devrai se mettre a jour suivant les modifications des fichiers linker (a chaque mise a jour du fichier celui ci s’incrémente et du coup le lien est rompu avec excel (ex: lors de la création du lien hypertexte en manuel le fichier se nomme "matrice_t3669-02M-104.drw.5 et quand je mets a jour le dit fichier, celui ci passe en "matrice_t3669-02M-104.drw.6 )

J’espère être assez claire dans mes explications, au besoin je fournit un exemplaire du fichier.

en tous cas merci d'avance, pour votre aide.

bonsoir,

une proposition de macro, à tester

Sub Macro1()
Selection.Hyperlinks.Delete
For Each t In Selection
    a = Dir(t & ".drw.*")
    If a <> "" Then
    ActiveSheet.Hyperlinks.Add Anchor:=t, Address:=a, TextToDisplay:=t
    End If
Next
End With
End Sub

Bonjour,

merci pour votre retour, mais ce code VBA ne fonctionne pas avec mes variables, en l’occurrence la variable "t".

Ce code doit-je l’intégrer dans une macro existante ou en crée une nouvelle?

Et si je peut abusé une petite explication sur le fonctionnement de votre code ne serai pas de refus.

Bonne journée.

Bonjour,

Ce n'était donc pas la bonne version de la macro, désolé.

voici quelques explications. Le code fonctionne en principe tel quel, mais tu peux l'intégrer dans un autre code si il y d'autres choses à faire, bien sûr.

Sub Macro1()
' on supprime tous les liens qui sant dans les cellules sélectionnées
Selection.Hyperlinks.Delete
' pour chaque cellule sélectionnée (t)
' chemin contient le nom du répoertoire où se trouvent les fichiers
chemin = ThisWorkbook.Path
For Each t In Selection
   ' on recherche si il existe un fichier dont le nom est composé du contenu de t suffixé par .drw.*
   a = Dir(chemin & "\" & t & ".drw.*")

    If a <> "" Then  ' si on trouve le fichier
' on recrée l'hyperlien (a) en cellule t avec comme texte le contenu de t

F = chemin & "\" & a
   ActiveSheet.Hyperlinks.Add Anchor:=t, Address:=F, TextToDisplay:=t.Value
    End If
Next

End Sub

NB: il faut sélectionner les cellules à modifier avant de lancer la macro.

Merci pour ces explications.

Je ne veut pas etre rabajoie, mais le texte du lien hypertexte est different du nom du fichier.

Es ce que cela ne vas pas poser de problème?

Et es ce que la mise a jour des liens tiens compte de l'endroit ou se trouve le fichier précédemment perdu? (ex: le lien hypertexte pointe sur un fichier dans un dossier différent de celui ou se trouve le fichier excel et d'autre lien pointe dans d'autres dossiers)

En tous cas merci je regarde ça demain au taf.

Bonne soirée.

RIRI91 a écrit :

Merci pour ces explications.

Je ne veux pas être rabat-joie, mais le texte du lien hypertexte est différent du nom du fichier.

Est-ce que cela ne va pas poser de problème?

j'ai essayé de tenir compte de tes explications.

Et est-ce que la mise a jour des liens tient compte de l'endroit où se trouve le fichier précédemment perdu? (ex: le lien hypertexte pointe

sur un fichier dans un dossier différent de celui où se trouve le fichier excel et d'autres liens pointent dans d'autres dossiers)

non, je regarde ce que peux faire

En tous cas merci je regarde ça demain au taf.

Bonne soirée.

re-bonsoir,

nouvelle verson avec recherche du fichier dans le répertoire indiqué par l'hyperlien.

Sub Macro1()
' pour chaque cellule sélectionnée (t)
    For Each t In Selection
        nolink = False

        On Error GoTo terreur
        'on récupère l'hyperlien existant, s'il y en a un
        h = t.Hyperlinks(1).Address
        On Error GoTo 0
        If nolink Then    ' pas d'hyperlien existant, par défaut le chemin pour le nouveau lien à créer est le même que celui de ce classeur
            chemin = ThisWorkbook.Path
        Else
            ' sinon on récupère le chemin et le nom de fichier, sur base du dernier \ trouvé
            st = InStr(h, "\")
            While st <> 0
                t1 = st
                st = InStr(st + 1, h, "\")
            Wend
            st = t1
            fichier = Mid(h, st + 1)
            chemin = Left(h, Len(h) - Len(fichier))
            ' on supprime le lien existant
            t.Hyperlinks.Delete
        End If
        ' on recherche si il existe un fichier dont le nom est composé du contenu de t suffixé par .drw.*
        a = Dir(chemin & "\" & t & ".drw.*")

        If a <> "" Then  ' si on trouve le fichier
            ' on recrée l'hyperlien (a) en cellule t avec comme texte le contenu de t

            F = chemin & "\" & a
            ActiveSheet.Hyperlinks.Add Anchor:=t, Address:=F, TextToDisplay:=t.Value
        End If
    Next
    Exit Sub
terreur:
    nolink = True
    Resume Next
End Sub

oua!!! ça c'est du code vba

Je testerai demain, je te tiens au jus.

En tous cas t'es un chef, et encore merci.

Bonjour,

Apres insertion du code dans le tableau, les liens se supprime bien, mais malheureusement ne se recrée pas.

Si ta une idée?

Cordialement.

Rebonjour,

J'ai solutionné en partie mon problème. En effet excel ne réussira pas a renommer les fichiers, donc les liens hypertexte seront toujours rompu.

Pour cela, j'ai trouvé un soft qui renomme les fichiers et supprime les incréments (*.drw.2;*.drw.3; etc...) en *.drw.1 du coup excel retrouve toujours ses petits. (

)

Par contre, je suis toujours en recherche pour créé les liens hypertexte de façon automatique.

Petit rappel:

Je souhaite, suivant une sélection de cellules, créé les liens hypertexte qui pointe dans le bon dossier, et au bon fichier.

Pour le fichier la création des liens devront prendre en compte le texte inscrit dans la cellule, car ce texte est une partie du nom du fichier (ex: dans la cellule est inscrit T3669-00M-018 et le nom du fichier se nomme cale_choc_sup_t3669-00M-018.drw.1)

ps: les chemins des dossiers sont dans l'onglet "chemins d'acces fichiers"

es ce que cela reste possible dans une macro expliqué?

par avance Merci!!

bonsoir,

code adapté

Sub majlien()

' on supprimer tous les liens liés aux cellules sélectionnées
On Error Resume Next ' si erreur est détectée passer à l'instruction suivante
Selection.Hyperlinks.Delete
On Error GoTo 0
' pour chaque cellule sélectionnée (t)
   For Each t In Selection
   ' on prend les 3 derniers chiffres de la référence pour trouver la ligne contenant le répertoire associé
        c = Int(Right(t, 3) / 100) + 1
        chemin = Worksheets("Chemins d'acces fichiers").Cells(c, 1)
        ' on recherche si il existe un fichier dont le nom contient le contenu de la cellule t
       a = Dir(chemin & "\*" & t & "*")

        If a <> "" Then  ' si on trouve le fichier
           ' on recrée l'hyperlien (a) en cellule t avec comme texte le contenu de t

            F = chemin & "\" & a
            ActiveSheet.Hyperlinks.Add Anchor:=t, Address:=F, TextToDisplay:=t.Value
        End If
    Next
End Sub

Bonsoir,

je vient d'essayé le code modifié, celui ci marche du tonnerre les liens sont crées automatiquement..

Par contre, j'ai oublie un problème dans chaque dossier il y a des fichiers *.prt et *.drw, les fichiers prt et drw ont le même nom

du coup la macro prend sur certain cas un fichier prt.

Ce qui me parait bizarre, c'est que dans le code d'avant tu spécifie bien drw. peut être une adaptation a faire? Si c'est possible.

Sinon, trop de la balle le code. et pour que ça fonctionne bien faut bien crée les liens de chemins des dossiers.

Merci, pour ton retour.

Bonsoir,

j'ai très difficile à pondre un code qui fonctionne sans avoir une bonne visibilité sur les noms de fichiers.

voici une modification, en espérant que cela fonctionnera...

Sub majlien()

' on supprimer tous les liens liés aux cellules sélectionnées
On Error Resume Next ' si erreur est détectée passer à l'instruction suivante
Selection.Hyperlinks.Delete
On Error GoTo 0
' pour chaque cellule sélectionnée (t)
  For Each t In Selection
   ' on prend les 3 derniers chiffres de la référence pour trouver la ligne contenant le répertoire associé
       c = Int(Right(t, 3) / 100) + 1
        chemin = Worksheets("Chemins d'acces fichiers").Cells(c, 1)
        ' on recherche si il existe un fichier dont le nom contient le contenu de la cellule t
      a = Dir(chemin & "\*" & t & ".drw*")

        If a <> "" Then  ' si on trouve le fichier
          ' on recrée l'hyperlien (a) en cellule t avec comme texte le contenu de t

            F = chemin & "\" & a
            ActiveSheet.Hyperlinks.Add Anchor:=t, Address:=F, TextToDisplay:=t.Value
        End If
    Next
End Sub

Bonjour,

Super, ça marche nickel. Un grand merci.

SI je veux adapter ce code a de nouveau dossier qui ont des valeurs différentes, mais une trame presque identique (ex: T4114-00M-001) qu'es ce que je peut changer dans ton code ou dans le fichier excel pour que ça fonctionne?

A te lire.

Bonjour,

le code se base sur les 3 derniers chiffres de la référence pour déterminer le répertoire asscocié. S'il faut appliquer une autre règle, il faudra modifier le code. Cette modification dépendra de la nouvelle règle.

bonjour,

voici un code adapté qui te permet de gérer le lien des répertoires sur base de caractéristiques de la référence

dans ton onglet "chemins d'accès fichiers" il faut remplacer les X ppar ? pour les parties variables de la référence en colonne B (ce que j'appele plus loin un masque); dès que l'on trouve un masque qui correspond à la référence la macro sélectionne le chemin associé..

à tester

Sub majlien()
If Selection.Parent.Name <> "Base de données" Then MsgBox "sélection non valable": Exit Sub
If Selection.Column <> 1 Then MsgBox "sélection non valable": Exit Sub
' on supprimer tous les liens liés aux cellules sélectionnées
    On Error Resume Next    ' si erreur est détectée passer à l'instruction suivante
    Selection.Hyperlinks.Delete
    dll = Worksheets("Chemins d'acces fichiers").Range("B" & Rows.Count).End(xlUp).Row
    On Error GoTo 0
    ' pour chaque cellule sélectionnée (t)
    For Each t In Selection
    ' on recherche le chemin dans l'onglet chemin d'accès sur base de le référence
          chemin = ""
        For i = 1 To dll
            If t.Value Like Worksheets("Chemins d'acces fichiers").Cells(i, 2) Then
                chemin = Worksheets("Chemins d'acces fichiers").Cells(i, 1): Exit For
            End If
        Next i
        If chemin <> "" Then 'on a trouvé le chemin, on cherche le fichier
            a = Dir(chemin & "\*" & t & ".drw*")

            If a <> "" Then  ' si on trouve le fichier
                ' on recrée l'hyperlien (a) en cellule t avec comme texte le contenu de t

                F = chemin & "\" & a
                ActiveSheet.Hyperlinks.Add Anchor:=t, Address:=F, TextToDisplay:=t.Value
            End If
        End If
    Next
End Sub

Bonjour,

Apres les tests, Je peut te confirmer, que tu vient de me sortir une bonne épine du pied. ça fonctionne nickel et je peut l'adapter pour d'autre dossier, faut juste être un rigoureux.

En tous cas,je te remercie grandement pour ton aide. Peut être sur un autre sujet j'aurai besoin de tes compétences.