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

[ShuarS]

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.

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

 

[Pounet95]

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]

Bonjour,

Essaie (non testé) :

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]

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

 

[ShuarS]

Bonjour @danielco ,

Je n'ai pas encore lancé mais est ce normal de voir deux lignes avec le OldStr ?

 

[danielco]

Désolé, supprime la seconde (la mienne).

Daniel

 

[ShuarS]

@danielco , erreur sur

HL.Address = NewHp

Je crois qu'il faudrait un if pour passer si le lien ne contient pas celui rechercher.
Possible ?

 

[danielco]

Quelle erreur ? Normalement, si l'adresse du lien n'est pas concernée, elle n'est pas modifiée. Poste la valeur de NewHp.

Sinon, mets un if.

Daniel

 

[ShuarS]

Bonjour @danielco et merci pour votre aide

Voici l'erreur :

Comment écrire proprement : "Si HL <> OldStr alors passe" ?

Merci

 

[danielco]

Peux-tu exécuter ce 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
  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]

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

 

[danielco]

Non, il s'arrête sur l'erreur. Tou n'est donc pas modifié.

 

[danielco]

Utilise celui-ci :

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

 

[ShuarS]

M E R V E I L L E U X

Merci bcp pour votre aide !

Bonne journée,
Shu