Arborescence et lien hypertexte
l
Bonjour,
Mon entreprise utilise pour certain de ses fichiers Excel un dossier partagé sur tous les PC de la boite.Dans ce dossier, se trouve toute une arborescence de sous-dossier qui classe les fichiers par années, type, etc.
Nous avons un fichier Excel qui contient la liste de tous les fichier du répertoire avec un lien hypertexte associé.
Mais les fichiers de l'arborescence changent souvent de place et les liens hypertexte sont donc incorrectes.
Je souhaiterais donc savoir s'il est possible de crée une macro qui va aller vérifié la validité de tous les liens hypertexte, et lorsque qu'il en trouve des mauvais, va prendre le nom associé, lancé une recherche dans toute l'arborescence, et généré un nouveau lien s'il trouve le fichier.
Invité
Bonjour Leoche21
Une petite présentation ICI serait sympa
J'avais créé du code pour ce genre de chose, mais si le lien n'est pas valide, cela le transfert dans une feuille "BAD"
Sub VérificationLiens()
Dim Lig As Long, DLig As Long
Dim ShtLD As Worksheet
' Définir la feuille
Set ShtLD = ThisWorkbook.Sheets("ListeDocs")
' Trouver la dernière ligne
DLig = ShtLD.Range("B" & Rows.Count).End(xlUp).Row
' Pour chaque ligne
For Lig = 4 To DLig
Application.StatusBar = "Traitement ligne : " & Lig & "/" & DLig
' Tester le lien hypertexte
If VerifHyperlink(ShtLD.Range("B" & Lig)) = False Then
' Si n'existe pas, basculer la ligne dans la feuille BAD
ShtLD.Rows(Lig).Copy Destination:=Sheets("BAD").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
If Err.Number = 0 Then ShtLD.Rows(Lig).Clear
End If
Next Lig
' Effacer la variable objet
Set ShtLD = Nothing
End Sub
Function VerifHyperlink(Cellule As Range) As Boolean
Dim Cible As String
'Vérifie si la cellule contient un lien hypertexte
If Cellule.Hyperlinks.Count = 0 And Left(Cellule.FormulaLocal, 5) <> "=LIEN" Then
VerifHyperlink = False
Exit Function
End If
'Extrait l'adresse du lien
On Error Resume Next
Cible = Cellule.Hyperlinks(1).Address
If Cible = "" Then
Cible = Cellule.FormulaLocal
Cible = Replace(Cible, "=LIEN_HYPERTEXTE(", "")
Cible = Mid(Cible, 2, InStr(2, Cible, Chr(34) & ";") - 2)
End If
On Error GoTo 0
'Vérifie si le fichier existe.
If Dir(Cible) <> "" And Cible <> "" Then
VerifHyperlink = True
Else
VerifHyperlink = False
End If
End FunctionCode à adapter pour votre besoin
@+