Macros-commandes VBA/Exercices/Remplacement des hyperliens

Remplacement d'hyperliens dans un classeur Excel

Nous nous proposons ici d'effectuer un exercice complexe pour mettre en pratique vos connaissances en termes de macros et ainsi automatiser certaines tâches. Dans le cas présent, il s'agit de la modification automatique d'hyperliens dans un classeur EXCEL.

Exemple

Voici son énoncé :

Créer un dossier "tests" puis 2 sous-dossiers "tests\A" et "tests\B"
Créer 3 documents WORD différents dans un dossier "tests\A" (doc1.docx, doc2.docx, doc3.docx)
Créer le classeur EXCEL "remplacer hyperliens.xlsm" dans le dossier "tests"
Créer en A1 un hyperlien vers le document "tests\A\doc1.docx"
Créer en A2 un hyperlien vers le document "tests\A\doc2.docx"
Créer en A3 un hyperlien vers le document "tests\A\doc3.docx"
Déplacer les 3 fichiers WORD dans le dossier "tests\B"
Vérifier que les liens ne fonctionnent plus
Inventer une macro qui modifiera automatiquement le dossier de lien de "tests\B" vers "tests\A" pour rétablir ces liens

Solution

Nous allons réaliser une macro qui permettra de récupérer chacun des liens à modifier, puis de changer le chemin de chaque lien
Pour ce faire, il faut ouvrir le fichier "remplacer hyperliens.xlsm" puis dans l'onglet DÉVELOPPEUR Visual Basic saisir le code VBA suivant :

' cette macro repère les liens hypertextes en colonne A et les affiche en colonne B
' les transforme par modification de dossier et affiche les transformations en colonne C
Sub CorrectionLiensHypertextes()
    Dim Cell As Range
    Dim Ligne As Integer
    Dim LienSource As String
    Dim LienCible As String
 
    'Récupère le numéro de la dernière ligne non vide
    Ligne = Columns(1).SpecialCells(xlCellTypeLastCell).Row
 
    'Boucle sur les cellules de la colonne A
    For Each Cell In Range("A1:A" & Ligne)
        'si un lien existe
        If Cell.Hyperlinks.Count > 0 Then
            ' récupère et écrit l'adresse de ce lien en colonne 2
            LienSource = Cell.Hyperlinks(1).Address
            Cell.Offset(0, 1) = LienSource
            ' intervertit les liens des dossiers A et B
            If Left(LienSource, 2) = "tests\B\" Then LienCible = Replace(LienSource, "tests\B\", "tests\A\")
            If Left(LienSource, 2) = "tests\A\" Then LienCible = Replace(LienSource, "tests\A\", "tests\B\")
            ' écrit l'adresse du lien transformé dans le lien puis en colonne 2
            Cell.Hyperlinks(1).Address = LienCible
            Cell.Offset(0, 2) = Cell.Hyperlinks(1).Address
            ' remplace le dossier source par le dossier cible
        End If
    ' va se positionner sur la prochaine cellule
    Next Cell
' ce code s'arrête quand la collection de cellules a été entièrement parcourue
End Sub

Ce code VBA
- parcourt les liens de la colonne 1
- remplace dans le lien le chemin du dossier A vers le dossier B (ou le contraire)
- affiche ancien lien et nouveau lien dans les colonnes B et C
Pour exécuter la macro, il vous suffit de
- effacer les colonnes B et C du classeur "remplacer hyperliens.xlsm"
- retourner dans dans l'onglet DÉVELOPPEUR Macros
- de sélectionner la macro "CorrectionLiensHypertextes"
- de l'exécuter

Remarque

Ce code peut être amélioré en ajoutant une recherche sur toutes les lignes et colonnes renseignées du document, et aussi en paramétrant via des champs paramètres les dossiers sources et les dossiers cibles : CorrectionLiensHypertextes(source, cible)

Conseil

Ne pas oublier l'Option Explicit en début de code et de bien nommer vos variables

Cet article est issu de Wikiversity. Le texte est sous licence Creative Commons - Attribution - Partage dans les Mêmes. Des conditions supplémentaires peuvent s'appliquer aux fichiers multimédias.