Option Explicit
Sub test()
Dim Cel As Long, Nom As String, Lien As String, fichier As String, Fich As String, Dest As String
Cel = 1
Nom = Cells(Cel, 1).Value
fichier = Range("a1").Hyperlinks(1).Address
Fich = ThisWorkbook.Path & "\" & Replace(fichier, "/", "\", 1, 2)
Lien = ThisWorkbook.Path & "\Archives\" & Range("b1") & "\" & Year(Date) & "\"
Dest = Lien & Nom & ".pdf"
'Créer les dossiers et sous dossiers
On Error Resume Next
MkDir (ThisWorkbook.Path & "\Archives")
On Error Resume Next
MkDir (ThisWorkbook.Path & "\Archives\" & Range("b1"))
On Error Resume Next
MkDir (Lien)
FileCopy Fich, Dest
Kill Fich
'rediriger le lien
ActiveSheet.Hyperlinks.Add anchor:=Cells(Cel, 1), Address:=Dest, TextToDisplay:=Nom
End Sub