Modification de lien hypertexte [masse] Excel
Résolu/Fermé
A voir également:
- Modification automatique lien hypertexte excel
- Lien url - Guide
- Liste déroulante excel - Guide
- Renommer un lien hypertexte - Forum Réseaux sociaux
- Créer un lien pour partager des photos - Guide
- Suivi de modification word - Guide
10 réponses
Bonjour,
Au cas où, j'ai eu moi-même ce problème de liens aà modifier en masse.
Cette macro m'a permis d'arriver à mes fins.
Attention cependant parfois la mise en page a été modifiée sur quelques cellules.
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
Au cas où, j'ai eu moi-même ce problème de liens aà modifier en masse.
Cette macro m'a permis d'arriver à mes fins.
Attention cependant parfois la mise en page a été modifiée sur quelques cellules.
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
Modifié par ender34 le 22/08/2014 à 10:51
2 déc. 2014 à 15:22