Amelioration macro

Bonjour à tous,

Ci-dessous ma macro qui fonctionne bien : elle va chercher le fichier PDF correspondant au compte projet et faire un lien hypertexte.

la macro se déclenche à chaque fois que j'appuie le bouton.

je souhaite l'améliorer pour qu'elle ne redémarre pas les lien hypertextes déjà trouvés: c'est à dire quand j'appuie sur le bouton qu'elle redémarre pas les lien hypertextes déjà trouvés, (qu'ils restent figés) mais qu'elle fasse uniquement ceux qui sont à faire.

Est possible ?

Merci pour votre aide.

Bien cordialement,

Private ListeDoss() As String
Dim fichier As String
Dim k As Integer

Sub ChercheDoss(Chemin1 As String)
Dim Ligne As Long, Nom As String
    Ligne = Range("N65536").End(xlUp).Row + 1
    On Error GoTo Err1
    Nom = Dir(Chemin1 & "\" & fichier & "*pdf")
    If Nom <> "" Then
        If Range("P" & CStr(k)).Value = Empty Then
            Range("P" & CStr(k)).Value = Nom
            ActiveSheet.Hyperlinks.Add Anchor:=ActiveSheet.Cells(k, 16), Address:=Chemin1 & "\" & Nom, TextToDisplay:=Nom
        End If
    End If
Err1:

End Sub

Sub ChercheTout()
Dim Chemin As String, i As Long

Range("P3:P65536").Clear
    Chemin = "I:\IPM\IPMM\IPM-MR\DMR ER GP S\Courrier"
    LanceListe Chemin
For k = 3 To 5000
    fichier = Range("N" + CStr(k)).Value

    If fichier = Empty Then
        MsgBox "SOURIEZ-vous êtes FILMES, Bonne Journée !!! Merci"
        Exit For
    End If

    For i = 1 To UBound(ListeDoss)
        ChercheDoss ListeDoss(i)
    Next i
Next k
End Sub

Sub ListeArborescence(Dossier As String)
Dim fs, sousdoss
    Set fs = CreateObject("Scripting.FileSystemObject")
    On Error Resume Next
    For Each sousdoss In fs.getfolder(Dossier).subfolders
        ReDim Preserve ListeDoss(1 To UBound(ListeDoss) + 1)
        ListeDoss(UBound(ListeDoss)) = sousdoss.Path
        ListeArborescence sousdoss.Path
    Next sousdoss
    On Error GoTo 0
    Set fs = Nothing
End Sub

Sub LanceListe(Dossier As String)
    ReDim ListeDoss(1 To 1)
    ListeDoss(1) = Dossier
    ListeArborescence Dossier
End Sub

Private Sub Workbook_Open()
    Call ChercheTout
End Sub

Bonsoir,

proposition d'adaptation de la macro cherchedoss (non testé)

Sub ChercheDoss(Chemin1 As String)
    Dim Ligne As Long, Nom As String
    Ligne = Range("N65536").End(xlUp).Row + 1
    On Error GoTo Err1
    Nom = Dir(Chemin1 & "\" & fichier & "*pdf")
    If Nom <> "" Then
        Set re = Columns("P").Find(Chemin1 & "\" & Nom)
        If re Is Nothing Then
            If Range("P" & CStr(k)).Value = Empty Then
                Range("P" & CStr(k)).Value = Nom
                ActiveSheet.Hyperlinks.Add Anchor:=ActiveSheet.Cells(k, 16), Address:=Chemin1 & "\" & Nom, TextToDisplay:=Nom
            End If
        End If
    End If
Err1:

End Sub

Bonjour à tous,

Merci pour ta réponse mais elle redémarre toujours les lien hypertextes déjà trouvés.

je souhaite l'améliorer pour qu'elle ne redémarre pas les lien hypertextes déjà trouvés: c'est à dire quand j'appuie sur le bouton qu'elle redémarre pas les lien hypertextes déjà trouvés, (qu'ils restent figés) mais qu'elle fasse uniquement ceux qui sont à faire.

Help me pour améliorer cette macro.

Merci à vous !

Cordialement