Macro trop lente

Bonjour à tous,

J'ai une macro qui fonction mais super lente.

Dans mon fichier EXCEL, grâce aux compte projets, la macro va chercher dans tout mon répertoire le fichier PDF correspondant et faire un lien hypertexte en face du compte projet.

Mais c'est TRES TRES LENT.

Est ce que il y a une astuce pour faire accélérer cette macro.

Pouvez vous m'aider à améliorer cette macro SVP.

Merci

Cordialement

Bonjour

je te propose cette modification, qui devrait normalement améliorer les choses, mais je n'ai pas pu tester

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

Bonjour

Merci pour cette réponse mais ca me marque erreur de compilation : sub ou fonction non définie

deton a écrit :

Bonjour

Merci pour cette réponse mais ca me marque erreur de compilation : sub ou fonction non définie

voici le code complet

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

WHAOOO , C'est super c'est plus rapide

Mais juste est ce que vous pouvez faire en sorte que la macro ne démarre pas à chaque ouverture du fichier excel sauf si je clique sur le bouton pour la mise à jour.

MERCI INFINIMENT DEJA.

Cordialement

Juste pour rajouter :

que la macro ne démarre pas quand j'ouvre le fichier excel : que les lien hypertexte restent figés sauf si je clique sur le bouton pour la mise à jour .

merci

Bonjour,

il te suffit d'enlever ces instructions

Private Sub Workbook_Open()
    Call ChercheTout
End Sub

Merci infiniment.

C'est super, merci beaucoup

Cordialement

Bonjour,

je suis un débutant sur Vba et j'ai du mal a comprendre comment il fonctionne ce code

je voudrais savoir s'il y a quelqu'un qui pourra commenter le code svp histoire de comprendre comment ça fonctionne

pour info : je veux utiliser ce code pour chercher des fichier .txt et puis vérifier le contenu de chaque fichier trouver

merci d'avance

Bonjour,

la macro ci-dessus n'est pas adaptée à ce que tu veux faire, voici une version épurée et commentée

Sub listefichierrecursive()
'cree un tableau a, contenant le nom de tous les fichiers dans le repétoire donné et ses sous-dossiers
    a = lfr("d:\downloads\", "*.txt")
    'on parcourt la liste des fichiers trouvés
    For i = LBound(a) To UBound(a)
        MsgBox a(i)
        'ton traitement du fichier trouvé
    Next i
End Sub

Function lfr(rep, filtre, Optional ByRef dict, Optional n = 0)
'fonction de recherche récursive dans le dossier rep
'filtre filtre pour les fichiers à sélectionner
'n niveau de récursivité

' on crée l'objet dictionnaire s'il n'existe pas encore
    If IsObject(dict) = False Then Set dict = CreateObject("scripting.dictionary")
    ' on crée l'objet filesystem
    Set fso = CreateObject("scripting.filesystemobject")
    'rep est l'objet correspondant au dossier en cours
    Set rep = fso.getfolder(rep)
    ' on parcourt tous les sous-dossiers du dossier en cours
    For Each repf In rep.subFolders
        lfr repf, filtre, dict, n + 1    ' on examine leur contenu, on incrémente le niveau de récursivité
    Next repf    'on passe au sous-dossier suivant
    'on parcourt tous les fichiers du dossier en cours
    For Each f In rep.Files
        fn = f.Name    'fn contient le nom du fichier en cours
        If f.Name Like filtre Then    'le fichier correspond-il au filtre ?
            dict.Add f.Path, 0    'oui on l'ajoute au dictionnaire
        End If
    Next f    ' on passe au fichier suivant
    If n = 0 Then lfr = dict.keys    'on est revenu au niveau 0, c'est la fin de la récursivité, on renvoie la liste des fichiers sous forme de tableau comme réponse pour la fonction
End Function

Super

merci beaucoup