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...