Optimisation 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
  

Coucou, je vois pas trop comment régler ton soucis de liens hypertextes, mais je sais qu'en mettant :

Application.ScreenUpdating =  false

au début de ton code (et True à la fin du code) tu vas gagner en temps d'exécution. J'ai des macros qui sont passées de 5 min d'exécution à moins de 10 secondes grâce à ça.

Bonjour,

Veux-tu que je mette " Application.ScreenUpdating = false " à quel niveau de la macro.

je suis un novice.

merci.

Cordialement

Bonjour,

Tu le mes après ton sub et avant ton Endsub

Sub...
Application.ScreenUpdating = false
.
.
.
.
Application.ScreenUpdating = true
End Sub

Merci pour ton retour mais quand je le fais ca me marque des messages d'erreur :

Sub...

Application.ScreenUpdating = false

Application.ScreenUpdating = true

Peux-tu me l'insérer dans la macro ci-dessous STP :

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("O65536").End(xlUp).Row + 1
    On Error GoTo Err1
    Nom = Dir(Chemin1 & "\" & fichier & "*pdf")
    If Nom <> "" Then
        Set re = Columns("Q").Find(Chemin1 & "\" & Nom)
        If re Is Nothing Then
            If Range("Q" & CStr(k)).Value = Empty Then
                Range("Q" & CStr(k)).Value = Nom
                ActiveSheet.Hyperlinks.Add Anchor:=ActiveSheet.Cells(k, 17), Address:=Chemin1 & "\" & Nom, TextToDisplay:=Nom
            End If
        End If
    End If
Err1:

End Sub

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

Range("Q3:Q65536").Clear
    Chemin = "I:\IPM\IPMM\IPM-MR\DMR ER GP S\Courrier"
    LanceListe Chemin
For k = 3 To 5000
    fichier = Range("O" + 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

Tu as mis "private" et pas "Private sub" ligne 1, je ne sais pas si c'est lié.

Sinon tu met Application.ScreenUpdating = false juste après, et Application.ScreenUpdating = True en tout dernier argument juste avant le end sub

oui c'est lié mais j'ai toujours un message d'erreur.

Dans la macro j'ai plusieurs sub, je met à chaque SUB

MERCI

Bonjour,

je n'ai pas compris ton message.

oui c'est lié mais j'ai toujours un message d'erreur.

Dans la macro j'ai plusieurs sub, je met à chaque SUB

MERCI