Macro rechercher remplacer liens hypertexte EXCEL 2010

Macro rechercher remplacer liens hypertexte EXCEL 2010 - VB/VBA/VBS - Programmation

Marsh Posté le 16-10-2015 à 17:45:37    

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. :heink:  :heink:  
Pas de message d'erreur
 
Voici les macros en question:
 
MACRO1:

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


 
MACRO2
 

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


 
MACRO3
 

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


 
Merci aux éventuelles personnes susceptibles de m'aider  :jap:  :jap:

Reply

Marsh Posté le 16-10-2015 à 17:45:37   

Reply

Sujets relatifs:

Leave a Replay

Make sure you enter the(*)required information where indicate.HTML code is not allowed