Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

Microsoft 365 Modification de masse de la racine d'un lien hyper text

ShuarS

XLDnaute Occasionnel
Salut à tous,

Auriez vous sous la main une macro pour modifier la racine de liens hyper text sur l'intégralité d'un classeur ?
Je n'ai pas d'exemple à partager désolé.

Pour faire simple le classeur possède de très nombreux onglets et des liens hyper text éparpillés de partout.
L'adresse du serveur vient de changer et je dois corriger cette racine.
Ex. : Ancienne adresse : "Lien supprimé"
Nouvelle adresse : ""

J'ai récupéré cette macro sur le net qui fonctionne très bien mais je n'arrive pas à la lancer sur l'intégralité du classeur.
VB:
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 = "\\Ogidoc1\Doc OGI\"
NewStr = "\\ogi.local\racineogi\data\OGIDOC\Doc ogi\"

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


Merci pour votre aide,
Shu
 
Solution
Utilise celui-ci :

VB:
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
  Dim Sh As Worksheet
  Dim HL As Hyperlink
  Dim Ctr As Long
 
  'Chemin à modifier
  OldStr = "http://svorodoc.corp.local/"
  NewStr = "http://webapps.corp.local/"
  Application.Calculation = xlManual
  On Error Resume Next
  For Each Sh In Sheets
    For Each HL In Sh.Hyperlinks
      Ctr = Ctr + 1
      OldHp = HL.Address
      NewHp = Replace(OldHp, OldStr, NewStr)
      DoEvents
      HL.Address = NewHp
    Next HL
  Next Sh
  On Error GoTo 0
  Application.Calculation = xlAutomatic
End Sub

Pounet95

XLDnaute Occasionnel
Bonjour,
Sauf si tu n'as pas mis tout ton code, je crois qu'il manque qq chose d'important, à savoir l'application de ce code à toutes les feuilles du classeur ( " mais je n'arrive pas à la lancer sur l'intégralité du classeur. ")
Un truc du genre :
Sub Tout_Le_Classeur
dim i as integer
for i= 1 to thisworkbook.sheets.count
sheets(i).activate
Modifier_lien
next i
end sub

Claude alias Pounet95
 

danielco

XLDnaute Accro
Bonjour,

Essaie (non testé) :

VB:
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
Dim Sh As Worksheet
Dim HL As Hyperlink

'Chemin à modifier
OldStr = "\\Ogidoc1\Doc OGI\"
NewStr = "\\ogi.local\racineogi\data\OGIDOC\Doc ogi\"
OldStr = "com"
Application.Calculation = xlManual
For Each Sh In Sheets
  For Each HL In Sh.Hyperlinks
    OldHp = HL.Address
    NewHp = Replace(OldHp, OldStr, NewStr)
    HL.Address = NewHp
  Next HL
Next Sh
Application.Calculation = xlAutomatic

End Sub

Cordialement.

Daniel
 

ShuarS

XLDnaute Occasionnel
Bonjour @Pounet95 et merci du retour,

Est il possible de faire lire les cellules sans pour autant sélectionner l'intégralité des feuilles ?

Le problème que je rencontre c'est qu'Excel plante à chaque fois que je lance cette macro sur "trop" de cellules sélectionnées...
 

danielco

XLDnaute Accro
Peux-tu exécuter ce code ?

VB:
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
  Dim Sh As Worksheet
  Dim HL As Hyperlink
  Dim Ctr As Long
 
  'Chemin à modifier
  OldStr = "http://svorodoc.corp.local/"
  NewStr = "http://webapps.corp.local/"
  Application.Calculation = xlManual
  For Each Sh In Sheets
    For Each HL In Sh.Hyperlinks
      Ctr = Ctr + 1
      OldHp = HL.Address
      NewHp = Replace(OldHp, OldStr, NewStr)
      DoEvents
      On Error GoTo Err
      HL.Address = NewHp
    Next HL
  Next Sh
  Application.Calculation = xlAutomatic
  Exit Sub
Err:
  Sheets.Add
  [A1] = NewHp
  [A2] = OldHp
  [A3] = HL.Range.Address
  [A4] = Ctr
  [A5] = Sh.Hyperlinks.Count
  Application.Calculation = xlAutomatic
End Sub

En cas d'erreur, la macro va ajouter une feuille et écrire des éléments dessus. Peux-tu me les communiquer ?

Daniel
 

ShuarS

XLDnaute Occasionnel
En A1 et A2 j'ai un lien sur un autre Excel sur notre serveur.
Puis :


Le code s'exécute complètement maintenant
Je crois que les erreurs possibles sont des liens morts.
Je vais regarder ça.

Merci bcp dans tous les cas

Shu
 
Dernière édition:

danielco

XLDnaute Accro
Utilise celui-ci :

VB:
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
  Dim Sh As Worksheet
  Dim HL As Hyperlink
  Dim Ctr As Long
 
  'Chemin à modifier
  OldStr = "http://svorodoc.corp.local/"
  NewStr = "http://webapps.corp.local/"
  Application.Calculation = xlManual
  On Error Resume Next
  For Each Sh In Sheets
    For Each HL In Sh.Hyperlinks
      Ctr = Ctr + 1
      OldHp = HL.Address
      NewHp = Replace(OldHp, OldStr, NewStr)
      DoEvents
      HL.Address = NewHp
    Next HL
  Next Sh
  On Error GoTo 0
  Application.Calculation = xlAutomatic
End Sub
 

Discussions similaires

Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…