Discussion :

[deton]

Bonjour à tous.

Je suis un novice en excel. ci-joint mes fichiers.

J'ai reçu l'aide d'une personne qui m'a rédigé cette macro, grâce à mes comptes projets dans mon fichier EXCEL, la macro va chercher dans tout mon répertoire le fichier PDF qui correspond au compte projet pour en faire un lien hypertexte.

Pouvez-vous m'aider à améliorer cette macro car super lent.

et j'aimerai aussi qu'elle ne redémarre pas à chaque ouverture du fichier, qu'elle reste figé sauf si je clique sur le bouton pour la mise à jour.

Merci pour votre aide.

Cordialement.

VOICI LA MACRO :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
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
 
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
 
    Chemin = "I:\IPM\IPMM\IPM-MR\DMR ER GP S\Courrier"
    LanceListe Chemin
    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

[Malick]

Pouvez-vous m'aider à améliorer cette macro car super lent.

Il serait plus judicieux de copier ici le code de la macro à améliorer (n'oubliez pas d'utiliser la balise # prévue à cet effet), car certains membres n'ouvrent pas les pièces jointes.

Cordialement

[deton]

Suite à mon sujet voici la macro :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
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
 
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
 
    Chemin = "I:\IPM\IPMM\IPM-MR\DMR ER GP S\Courrier"
    LanceListe Chemin
    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

[Menhir]

+1 avec milkoseck pour ce qui est de la non-ouverture des pièces jointes.

et j'aimerai aussi qu'elle ne redémarre pas à chaque ouverture du fichier, qu'elle reste figé sauf si je clique sur le bouton pour la mise à jour.

Ta macro doit sans doute être dans un évènement Workbook_Open du module Workbook de ton fichier dans ton gestionnaire de projet.

Dans le gestionnaire de projet, tu insères un module pour ton fichier.
Tu crées dedans une nouvelle macro, par exemple :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
Sub MonLink()
 
End Sub

Tu recopies dedans le contenu de ta macro Workbook_Open.
Tu fais un clic droit dans ta barre d'outil d'accès rapide > Personnaliser la barre d'outil d'accès rapide > Catégorie = Macros
Dans la liste, tu choisies la macro que tu viens de créer (MonLink dans mon exemple) > Ajouter pour le passer dans le liste de droite.
Tu le sélectionnes dans la liste de droite > Bouton Modifier
Tu lui choisis une icone qui te va bien.
Tu valides tout ça à coup de bouton OK.

A partir de là, tu pourras lancer ta macro avec ce bouton.

N'oublie pas de supprimer la macro Workbook_Open si tu ne veux plus qu'elle se déclenche à l'ouverture.

[deton]

je suis un peu novice, qu'est ce que tu appelles "ta barre d'outil d'accès rapide > Personnaliser la barre d'outil d'accès rapide > Catégorie = Macros" ??? moi j'ai excel 2007.
as tu une idée pour la macro qui est super lente
merci

[deton]

je suis un peu novice, qu'est ce que tu appelles "ta barre d'outil d'accès rapide > Personnaliser la barre d'outil d'accès rapide > Catégorie = Macros" ??? moi j'ai excel 2007.
as tu une idée pour la macro qui est super lente
merci

voici la macro :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
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
 
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
 
    Chemin = "I:\IPM\IPMM\IPM-MR\DMR ER GP S\Courrier"
    LanceListe Chemin
    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

[cerede2000]

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
fichier = Range("N" + CStr(k)).Value
 
    If fichier = Empty Then
        MsgBox "SOURIEZ-vous êtes FILMES, Bonne Journée !!! Merci"
        Exit For
    End If

[deton]

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
fichier = Range("N" + CStr(k)).Value
 
    If fichier = Empty Then
        MsgBox "SOURIEZ-vous êtes FILMES, Bonne Journée !!! Merci"
        Exit For
    End If

Merci mais J'ai pas compri votre reponse

[Menhir]

je suis un peu novice, qu'est ce que tu appelles "ta barre d'outil d'accès rapide > Personnaliser la barre d'outil d'accès rapide > Catégorie = Macros" ??? moi j'ai excel 2007.

En 2007, ça correspond à une barre d'outils personnalisée.
de mémoire (ça fait plusieurs années que je n'ai pas touché à un 2007), tu fais un clic droit sur les barres d'outils et tu peux ajouter une fonction à une barre d'outil existante ou créer une nouvelle barre d'outils. Quelle que soit ton choix, tu places dans la barre d'outils une nouvelle fonction en prenant comme catégorie les macros. Tu crées bouton lié à la macro ChercheTout.

as tu une idée pour la macro qui est super lente

J'ai quelques idées.
Déjà, je pense que le getfolder n'est pas judicieux. Une boucle sur Dir(Chemin,vbDirectory) serait sans doute plus léger.

Mais surtout, le développeur s'est amusé à créer tout un tas de macro qui s'enchainent sans cohérence entre elles. Donc, à chaque tour de la boucle, il est obligé de réinventer la roue, par exemple en cherchant la dernière ligne utilisée avec un Range("N65536").End(xlUp).Row alors que s'il avait fait ça en une seule macro, il aurait pu le gérer en incrémentant une variable.
A mon avis, concaténer tes quatre macros (je ne compte pas Workbook_Open qui ne fait que lancer la macro racine), pourrait permettre de faire un ensemble plus cohérent et sans doute plus rapide.

Et pour répondre à la question que tu t’apprêtes à poser, je réponds tout de suite : non, ce n'est pas moi qui vais m'y coller.

[deton]

En 2007, ça correspond à une barre d'outils personnalisée.
de mémoire (ça fait plusieurs années que je n'ai pas touché à un 2007), tu fais un clic droit sur les barres d'outils et tu peux ajouter une fonction à une barre d'outil existante ou créer une nouvelle barre d'outils. Quelle que soit ton choix, tu places dans la barre d'outils une nouvelle fonction en prenant comme catégorie les macros. Tu crées bouton lié à la macro ChercheTout.


J'ai quelques idées.
Déjà, je pense que le getfolder n'est pas judicieux. Une boucle sur Dir(Chemin,vbDirectory) serait sans doute plus léger.

Mais surtout, le développeur s'est amusé à créer tout un tas de macro qui s'enchainent sans cohérence entre elles. Donc, à chaque tour de la boucle, il est obligé de réinventer la roue, par exemple en cherchant la dernière ligne utilisée avec un Range("N65536").End(xlUp).Row alors que s'il avait fait ça en une seule macro, il aurait pu le gérer en incrémentant une variable.
A mon avis, concaténer tes quatre macros (je ne compte pas Workbook_Open qui ne fait que lancer la macro racine), pourrait permettre de faire un ensemble plus cohérent et sans doute plus rapide.

Et pour répondre à la question que tu t’apprêtes à poser, je réponds tout de suite : non, ce n'est pas moi qui vais m'y coller.

En macro je ne connais pas grand chose mais je viens sur ce forum pour obtenir de l'aide.
Merci pour ta reponse.

[Menhir]

je viens sur ce forum pour obtenir de l'aide.

Et de l'aide t'a été fournie.

Cependant, tu dois comprendre que je préfère passer ma soirée à m'occuper de ma fille plutôt que de la passer à réécrire du code pour une personne qui m'aura oublié moins de 10 min après avoir obtenu ce qu'elle souhaite.

[deton]

Et de l'aide t'a été fournie.

Cependant, tu dois comprendre que je préfère passer ma soirée à m'occuper de ma fille plutôt que de la passer à réécrire du code pour une personne qui m'aura oublié moins de 10 min après avoir obtenu ce qu'elle souhaite.

Ecoute, je cherche juste de l'aide, si tu ne peux pas c'est pas une obligation.
il y a peut être d'autres qui peuvent.

Merci à toi.

Cordialement,

[clementmarcotte]

Le problème de lenteur, c'est l'utilisation de FileSystemObject qui est notoirement très lent.

J'ai reçu l'aide d'une personne qui m'a rédigé cette macro, grâce à mes comptes projets dans mon fichier EXCEL, la macro va chercher dans tout mon répertoire le fichier PDF qui correspond au compte projet pour en faire un lien hypertexte.

Pouvez-vous m'aider à améliorer cette macro car super lent.

C'est à l'auteur d'assurer le Service après-vente.

[unparia]

Le problème de lenteur, c'est l'utilisation de FileSystemObject qui est notoirement très lent.

+ 100
Lent, certes, mais également lourd et, "cerise sur le gâteau", inaccessible sur certaines machines (par décision de leur propriétaire).

[parmi]

Dans ton code, il y a ceci

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
Private Sub Workbook_Open()
    Call ChercheTout
End Sub

Efface ça et mets un rectangle sur ta feuille (menu Insertion > Formes)
Clique droit sur ce rectangle et choisit "Affecter une macro"
Choisis ChercheTout

Donc, quand tu cliqueras le bouton, ça va appeler cette macro qui semble être le départ...

Pour accélérer un peu, tu pourrais changer cette macro de cette façon

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
Sub ChercheTout()
    Dim Chemin As String, i As Long
 
    Application.ScreenUpdating = False  'l'affichage sera gelé durant la macro
    Application.Calculation = xlCalculationManual   'on se met en mode calcul manuel pour accélérer s'il y a des formules
 
    Range("P3:P65536").Clear
 
    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
 
        Chemin = "I:\IPM\IPMM\IPM-MR\DMR ER GP S\Courrier"
        LanceListe Chemin
        For i = 1 To UBound(ListeDoss)
            ChercheDoss ListeDoss(i)
        Next i
    Next k
 
'On remet le tout par défaut
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

[deton]

Bonjour,
Merci infiniment pour ton aide.

Excellente journée à toi