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