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

ShuarS · 23 Septembre 2020

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

danielco · 24 Septembre 2020

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 · 23 Septembre 2020

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 · 23 Septembre 2020

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 · 23 Septembre 2020

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 · 23 Septembre 2020

Bonjour @danielco ,

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

danielco · 23 Septembre 2020

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

Daniel

ShuarS · 23 Septembre 2020

@danielco , erreur sur

VB:

HL.Address = NewHp

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

danielco · 23 Septembre 2020

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 · 24 Septembre 2020

Bonjour @danielco et merci pour votre aide

Voici l'erreur :

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

Merci

danielco · 24 Septembre 2020

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 · 24 Septembre 2020

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 · 24 Septembre 2020

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

danielco · 24 Septembre 2020

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

ShuarS · 24 Septembre 2020

M E R V E I L L E U X

Merci bcp pour votre aide !

Bonne journée,
Shu

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

ShuarS

XLDnaute Occasionnel

danielco

Pounet95

XLDnaute Occasionnel

danielco

XLDnaute Accro

ShuarS

XLDnaute Occasionnel

ShuarS

XLDnaute Occasionnel

danielco

XLDnaute Accro

ShuarS

XLDnaute Occasionnel

danielco

XLDnaute Accro

ShuarS

XLDnaute Occasionnel

danielco

XLDnaute Accro

ShuarS

XLDnaute Occasionnel

danielco

XLDnaute Accro

danielco

XLDnaute Accro

ShuarS

XLDnaute Occasionnel

Discussions similaires