Discussion :

[corias]

Bonjour,

Je souhaite modifier des liens hypertextes de classeurs excel (sous excel 2010) en masse(à cause d'un changement de serveur).
En fait ce serait du coup seulement le début du lien à modifier

exemple :
remplacer \\serveur1\dossier 2\

par \\serveur4\partage\dossier 2\

Je ne sais pas si le file:/// avant l'adresse doit être pris en compte.
J'ai trouvé au moins 3 macros différentes sur le net mais aucune ne fonctionne.
Pas de message d'erreur

Voici les macros en question:

MACRO1:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
Sub Modifier_lien()
 
 
Dim Doc As Workbook
Dim Cell As Range
Dim OldStr As String
Dim NewStr As String
Dim OldHp As String
Dim NewHp As String
 
 
'Chemin à modifier
 
OldStr = "\\serveur1\dossier 2\"
NewStr = "\\serveur4\partage\dossier 2\"
 
Application.Calculation = xlManual
 
Set Doc = Application.ActiveWorkbook
For Each Cell In Selection
 
'Verifie si la cellule contient des liens hypertexte
 
If Cell.Hyperlinks.Count > 0 Then
 
'Recupère l'adresse du lien sous forme de chaine
OldHp = Cell.Hyperlinks(1).Address
'Remplace l'ancienne chaine par la nouvelle
NewHp = Replace(OldHp, OldStr, NewStr)
'Supprime tous les liens hypertexte de la cellule
Cell.Hyperlinks.Delete
'Affecte le nouveau lien hypertexte
Doc.ActiveSheet.Hyperlinks.Add Anchor:=Cell, Address:=NewHp
End If
Next Cell
Application.Calculation = xlAutomatic
 
 
End Sub

MACRO2

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
Sub FixHyperlinks()
    Dim hl As Hyperlink
    For Each hl In ActiveSheet.Hyperlinks
        hl.Address = Replace(hl.Address, "\\serveur1\dossier 2\", "\\serveur4\partage\dossier 2\")
    Next hl
End Sub

MACRO3

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
Sub FindReplaceHLinks(sFind As String, sReplace As String, _
    Optional lStart As Long = 1, Optional lCount As Long = -1)
 
    Dim rCell As Range
    Dim hl As Hyperlink
 
    For Each rCell In ActiveSheet.UsedRange.Cells
        If rCell.Hyperlinks.Count > 0 Then
            For Each hl In rCell.Hyperlinks
                hl.Address = Replace(hl.Address, sFind, sReplace, lStart, lCount, vbTextCompare)
            Next hl
        End If
    Next rCell
End Sub
 
Sub Doit()
 
    FindReplaceHLinks "\\serveur1\dossier 2\", "\\serveur4\partage\dossier 2\"
 
End Sub

Merci aux éventuelles personnes susceptibles de m'aider

[vinc_bilb]

Bonjour,

Vous restez à priori sur la sheet active ..... et pour peu qu'elle n'ait pas de HL

Testez peut-être où ils sont, comme (non testé)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
Sub list_all_links()
 
    Dim HL As Hyperlink
    Dim Wsh As Worksheet, HLLog As String
 
    For Each Wsh In ThisWorkbook.Worksheets
 
        If Wsh.Hyperlinks.Count > 0 Then
 
            For Each HL In Wsh.Hyperlinks
                Debug.Print Wsh.Name, HL.Address, HL.Name, HL.Range.AddressLocal
                HLLog = HLLog & Wsh.Name & vbTab & HL.Address & vbTab & HL.Name & vbTab & HL.Range.AddressLocal
            Next HL
 
        End If
 
    Next Wsh
 
    If HLLog <> "" Then MsgBox HLLog
 
End Sub

[corias]

Bonjour,

Merci pour votre réponse. Il y a biens des liens.
Je pars d'ailleurs d'un classeur vierge (pour tests) surlequel j'ai mis un lien en A1.

Votre module trouve bien le lien en question et l'affiche dans une msgbox mais aucune de mes trois macros ne le modifie...

[OursTortue]

J'ai pas tout testé mais la deuxième fonctionne correctement.

Attention toutefois, cela ne modifie que l'adresse et pas le nom affiché.

De plus, il faut faire attention au nom complet du lien hypertexte.

Par exemple chez moi, quand je faire un lien vers Z:\toto, le lien hypertexte est : \\ja****.loc\data\toto

Donc par exemple si je veux changer mon Z:\toto en Z:\tata

il faudrait écrire

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
Sub FixHyperlinks()
    Dim hl As Hyperlink
    For Each hl In ActiveSheet.Hyperlinks
        hl.Address = Replace(hl.Address, "\\ja****.loc\data\toto", "Z:\tata")
    Next hl
End Sub

[corias]

J'ai pas tout testé mais la deuxième fonctionne correctement.

Bizarre ça ne fonctionne pas chez moi. En tous cas apparemment il est inutile de mettre file:/// (qui apparait quand on survole).

Je me demande si ça remplace le contenu exactement ou si il sait remplacer le début d'un lien contenant le texte ...le but étant de modifier juste le chemin de l'ancien serveur par celui du nouveau.

C'est fou qu'un macro si courte fonctionne chez vous et pas chez moi et qu'il n'y ait pas de message.

[vinc_bilb]

Voir proposition ci-dessous si ça peut aider ....

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
Sub Replace_HL_Adress()
 
    Dim Hl As Hyperlink, Wsh As Worksheet
    Dim Msgprompt As String, Msganswer As String, LogInfo As String, LogWarn As String
    Dim ConfirmB As Boolean     ' Confirmation individuelle lien par lien
    Dim SearchTxt As String, ReplaceTxt As String, ReplAnsw As String
    Dim HLReplCnt As Integer
 
' Chaines à trouver / remplacer
    SearchTxt = "C:\"
    ReplaceTxt = "E:\"
 
' Confirmation individuelle *** à changer ***
    ConfirmB = True
 
    HLReplCnt = 0
 
' On parcourt toutes les sheets de la collection puis tous les HL de chaque sheet
    For Each Wsh In ActiveWorkbook.Worksheets
 
        LogInfo = vbNullString
 
        If Wsh.Hyperlinks.Count > 0 Then
 
            For Each Hl In Wsh.Hyperlinks
 
                ReplAnsw = Replace(Hl.Address, SearchTxt, ReplaceTxt, , , vbTextCompare)
 
                If ReplAnsw <> vbNullString Then    'On remplace seulement si la chaine a été trouvée
 
                    If ConfirmB = True Then
 
                        Msgprompt = "Changement adress de l'hyperlien " & Wsh.Name & "-" & Hl.Range.Address & "-" & Hl.Address & "?"
                        Msganswer = MsgBox(Msgprompt, vbYesNo)
 
                    End If
 
                    If Msganswer = vbYes Or ConfirmB = False Then
 
                        ReplAnsw = Replace(Hl.Address, SearchTxt, ReplaceTxt, , , vbTextCompare)
                        HLReplCnt = HLReplCnt + 1
                        LogInfo = LogInfo & HLReplCnt & "/" & Hl.Name & vbTab & Hl.Address & vbTab & Hl.Range.Address & vbCrLf
 
                    End If
 
                Else:   LogWarn = LogWarn & "Pas de ramplacement pour: " & Hl.Name & vbTab & Hl.Address & vbTab & Hl.Range.Address & vbCrLf
                End If
 
            Next Hl
 
        End If
 
    Next Wsh
 
' Rapport
    If LogInfo <> vbNullString Then
 
        LogInfo = LogInfo & " remplacements pour " & ActiveWorkbook.Name & vbCrLf & LogInfo
        MsgBox LogInfo
 
    End If
 
    If LogWarn <> vbNullString Then
 
        LogWarn = " Warning: " & ActiveWorkbook.Name & vbCrLf & LogWarn
        MsgBox LogWarn, vbExclamation
 
    End If
End Sub

[corias]

Merci vinc_bilb...
Ta macro détecte bien les liens mais quand je mets oui elle ne les modifie pas non plus...

[OursTortue]

Possible d'avoir le classeur sans macro avec les liens dedans?

[corias]

Je viens d'ajouter le classeur avec les liens et les macros que j'ai trouvé.

Test_links.xlsm

[vinc_bilb]

Merci vinc_bilb...
Ta macro détecte bien les liens mais quand je mets oui elle ne les modifie pas non plus...

Bonjour
Je pense que si ..... editez l'hyperlink après et regardez l'adresse ....

Il y a une grosse différence entre TextToDisplay (ce qui est affiché) et Address (le lien effectif)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Exemple: ActiveSheet.Hyperlinks.Add Anchor:=Range("A1"), Address:="c:\", TextToDisplay:="titi"

dans l'exemple que je vous ai fourni, je modifie l'adresse mais pas le texte
Pensez bien à modifier

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
SearchTxt = "C:\"
ReplaceTxt = "E:\"

[corias]

Merci de votre réponse, je sais bien qu'il y a une différence.
En fait je regarde ce qu'il s'affiche dans la bulle pop-up jaune en survolant le lien et ce n'est pas modifié. Quand je fais modifier le lien il est impossible devoir le lien complet, le début est remplacé par "...\".

[vinc_bilb]

Bonjour,

La fonction replace retourne la chaine d'origine si la chaine a trouver n'est pas présente ..... donc dans votre cas, on remplace par la même valeur ...

J'ai modifié le code pour rajouter une recherche de présence de la chaine cible avant de chercher à la replacer + quelques bricoles

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
Sub Replace_HL_Adress()
 
    Dim Hl As Hyperlink, Wsh As Worksheet
    Dim Msgprompt As String, Msganswer As String, LogInfo As String, LogWarn As String
    Dim ConfirmB As Boolean     ' Confirmation individuelle lien par lien
    Dim SearchTxt As String, ReplaceTxt As String, ReplAnsw As String
    Dim HLReplCnt As Integer
 
' Chaines à trouver / remplacer
    SearchTxt = "..\" '"\\fpari01srv1.ddom.ad.corp\share\NC\"
    ReplaceTxt = ThisWorkbook.Path & "\"  '"B:\Share\A000000210\NC\"
 
' Confirmation individuelle *** à changer ***
    ConfirmB = True
 
    HLReplCnt = 0
 
' On parcourt toutes les sheets de la collection puis tous les HL de chaque sheet
    For Each Wsh In ActiveWorkbook.Worksheets
 
        LogInfo = vbNullString
 
        If Wsh.Hyperlinks.Count > 0 Then
 
            For Each Hl In Wsh.Hyperlinks
 
            ' On vérifie que le texte à remplacer est bien présent
                If InStr(1, Hl.Address, SearchTxt, vbTextCompare) > 0 Then
 
                   ReplAnsw = Replace(Hl.Address, SearchTxt, ReplaceTxt, , , vbTextCompare)
 
                    If ConfirmB = True Then
 
                        Msgprompt = "Changement adress de l'hyperlien " & Wsh.Name & "-" & Hl.Range.Address & vbCrLf & Hl.Address & "?" & _
                            String(2, vbCrLf) & "Par: " & ReplAnsw
                        Msganswer = MsgBox(Msgprompt, vbYesNo)
 
                    End If
 
                    If Msganswer = vbYes Or ConfirmB = False Then
 
                       HLReplCnt = HLReplCnt + 1
 
                       Debug.Print HLReplCnt, Hl.Address, ReplAnsw
                       LogInfo = LogInfo & HLReplCnt & "/" & Hl.Name & vbTab & Hl.Address & vbTab & Hl.Range.Address & vbCrLf
 
                       Hl.Address = ReplAnsw
 
                   End If
 
                Else:   LogWarn = LogWarn & "Sheet " & Wsh.Name & ": " & "-cell: " & Hl.Range.Address & " " & Hl.Address & vbCrLf
                End If
 
            Next Hl
 
        End If
 
    Next Wsh
 
' Rapport
 
    LogInfo = HLReplCnt & " remplacements pour " & ActiveWorkbook.Name & vbCrLf & LogInfo
    MsgBox LogInfo
 
 
    If LogWarn <> vbNullString Then
 
        LogWarn = " Warning: " & ActiveWorkbook.Name & vbCrLf & "Pas de remplacements pour:" & vbCrLf & LogWarn
        MsgBox LogWarn, vbExclamation
 
    End If
End Sub

et voici la sortie debug par exemple

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

 1            ..\J BERNARD\NI3_workload_20150423_SM REAL HOURS.xls    C:\Users\vb\Downloads\J BERNARD\NI3_workload_20150423_SM REAL HOURS.xls