Sub ChangeHyperlinks()
On Error Resume Next
Dim ws As Worksheet, N As Integer, NbError, indexLog
CreerFeuilleLog
NbError = 0
indexLog = 2
For Each ws In Worksheets
ws.Activate
For Each h In ActiveSheet.Hyperlinks
N = N + 1
'On trouve l'emplacement du !
PointExclam = InStr(1, h.SubAddress, "!", vbTextCompare)
AncienNom = Mid(h.SubAddress, 1, PointExclam)
'On remplace par le nom de la feuille actuelle
If Err > 0 Then ' si erreur remplit la feuille Log
NbError = NbError + 1
Sheets("Log").Cells(indexLog, 1) = ws.Name
Sheets("Log").Cells(indexLog, 2) = h.SubAddress
Sheets("Log").Cells(indexLog, 3) = AncienNom
Sheets("Log").Cells(indexLog, 4) = PointExclam
Sheets("Log").Cells(indexLog, 5) = Replace(h.SubAddress, AncienNom, ws.Name & "!")
Sheets("Log").Cells(indexLog, 6) = NbError
Sheets("Log").Cells(indexLog, 7) = N
Sheets("Log").Cells(indexLog, 8) = Err.Number
Err.Clear
indexLog = indexLog + 1
Else
h.SubAddress = Replace(h.SubAddress, AncienNom, ws.Name & "!")
End If
Application.StatusBar = "NbError = " & NbError & " - Hyperlinks changed : " & N
Next
Next
'Application.StatusBar = ""
End Sub
Sub CreerFeuilleLog()
On Error GoTo SiErreur
Dim Feuille As Worksheet
FeuilleExiste = False
For Each Feuille In Worksheets
If Feuille.Name = "Log" Then
FeuilleExiste = True
End If
Next Feuille
If FeuilleExiste = False Then
Sheets.Add(Before:=Sheets("LISTES")).Name = "Log"
End If
initlog
Exit Sub
SiErreur:
MsgBox "ERREUR"
End Sub
Sub initlog()
Sheets("Log").Select
Cells.Select
Selection.ClearContents
Range("A1").Select
Sheets("Log").Cells(1, 1) = "ws.Name"
Sheets("Log").Cells(1, 2) = "h.SubAddress"
Sheets("Log").Cells(1, 3) = "AncienNom"
Sheets("Log").Cells(1, 4) = "PointExclam"
Sheets("Log").Cells(1, 5) = "Replace"
Sheets("Log").Cells(1, 6) = "NbError"
Sheets("Log").Cells(1, 7) = "No links"
Sheets("Log").Cells(1, 8) = "No d'erreur"
End Sub