Microsoft 365 Optimiation de macro

[Akortys]

Bonjour,

J'ai une macro qui a été réalisé par un de mes amis.
Cette macro, scrute un ensemble de répertoire et de sous répertoire pour en retirer des informations et les insérer dans le fichier excel en question.

Le temps d’exécution de cette macro est extrêmement long. L'objectif est donc d'optimiser cette macro si possible. Je ne vois pas comment je peux l'optimiser sachant que mes compétences sont limitées sur le sujet.

Pour le bon fonctionnement, il y a un module a activé => Ce lien n'existe plus

La partie copy des information dans les deux autres fichiers Excel peut être commentée, ce n'est pas une partie gourmande en ressource, enfin je crois.

Si vous aviez un moment pour jeter un coup d'oeil et m'aiguiller dans la réflexion, ce serait sympathique.

En vous remerciant du temps passé.

Bonne journée

 

[Dudu2]

Bonjour,
Le code boucle sur une grand nombre d'ouvertures de classeurs pour y récupérer 1 valeur de la feuille active à l'ouverture.

Si toutes les feuilles actives à l'ouverture des classeurs ouverts ont le même nom, valorise la constante NomFeuille de ce nom et applique les modifs suivantes qui te donnent l'option d'ouvrir ou pas.

#Const LECTURESANSOUVRIR = True

#If LECTURESANSOUVRIR Then
                            Const NomFeuille = "Feuil1"
                            DesignationMachine = ExtraireValeur(.Files(i).strPathName, .Files(i).strFileName, NomFeuille, "D2")
#Else
                            Workbooks.Open Filename:=.Files(i).strPathName & "\" & .Files(i).strFileName, local:=True
                           
                            Range("D2").Select
                            DesignationMachine = Selection
                            'Stop
                            ActiveWorkbook.Close
#End If

A la fin du module ajoute cette fonction:

Function ExtraireValeur(ByVal Dossier As String, ByVal Fichier As String, ByVal Feuille As String, ByVal Cellule As String) As Variant
    Dim Argument As String
   
    If Right(Dossier, 1) <> "\" Then Dossier = Dossier & "\"
    Fichier = Replace(Fichier, "'", "''")
    Argument = "'" & Dossier & "[" & Fichier & "]" & Feuille & "'!" & Range(Cellule).Address(, , xlR1C1)
    'MsgBox Argument
    ExtraireValeur = ExecuteExcel4Macro(Argument)
End Function

 

[Dudu2]

Toutes les références au classeur de la macro (Client-MachineA_RENSEIGNER.xlsm) devraient être:
Windows(ThisWorkbook.Name).Activate
au lieu de
Windows("Client-MachineA_RENSEIGNER.xlsm").Activate

 

[patricktoulon]

bonjour
j récapitule voir si j'ai bien compris
tu a x fichiers dans dossiers et sous dossiers dans un dossier maître
dans chacun de ces fichier tu récupère la valeur de [D2]pour la mettre dans un fichier sans doute a la suite dans un tableau
ai-je bien compris la situation ?
deja le clfileshearch me semble t il a été développé pour 2007 qui avait perdu cette fonction et il est a mon gout un peu lourdaud
un fonction récursive avec dir est largement plus rapide
ensuite oui la fonction ExecuteExcel4Macro est tout indiqué pour aller chercher une cellule dans un fichier fermé (voir si la formule dans la cell de destination accélérerait pas encore un peu)
pour info de combien de fichiers parlent on ?

 

[Akortys]

Bonjour,

Effectivement sur le principe tu as bien compris.
Euuuuuh, fonction récursive dir, ......

On parle de 1096 fichiers dans 96 dossiers en tout

 

[patricktoulon]

d'accords
donc si j'ai bien compris ces 1096 fichier au final sont dans un dossier maitre eparpillé un peu partout dans des sous dossiers
on est ok ?

 

[Akortys]

C'est exactement cela.

 

[patricktoulon]

d'accords pour commencer
je te propose de tester mon listeur de fichier ".xls*"
ferme pour l'instant ton fichier de travail et ouvre en un neuf et colle ce code dans un module
et dit moi si tu choppe tout tes fichier
ADAPTE BIEN SUR LE CHEMIN de base du dossier maître
et dis moi combien de temps ca prends pour tous les chopper
lance la sub "testXy" pour tester

Sub testXy()
    Cells.Clear
    Dim liste As Variant
    liste = DirList("G:\vba excel\")'!!!! CHEMIN DU DOSSIER MAITRE A ADAPTER!!!!!!!
    Cells(1, 1).Resize(UBound(liste), 1).Value = Application.Transpose(liste)
End Sub

Function DirList(Dossier As String, Optional recall As Boolean = False, Optional tbl As Variant) As Variant
    Dim ItemVu As String, directory As Variant, SubFolderCollection As Collection, I As Long, A As Long, E As Long
    Set SubFolderCollection = New Collection
    If recall = False Then ReDim tbl(0)    ' si recall  on redim un tableau  de zero item (pour la creation du tableau)
    On Error Resume Next    'gestion des fichiers dossiers system et interdit ou generant une erreur(PerLog,recycle,etc..)
    ItemVu = Dir(Dossier, vbDirectory)
    If Error.Number = 0 Then    ' si pas d'erreur on examine le contenu
        'examen  du dossier courrant
        Do Until ItemVu = vbNullString
            If Left(ItemVu, 1) <> "." Then
                If (GetAttr(Dossier & ItemVu) And vbDirectory) = vbDirectory Then
                    SubFolderCollection.Add ItemVu
                Else
                   If Right(ItemVu, 5) Like ".xls*" Then A = UBound(tbl) + 1: ReDim Preserve tbl(1 To A): tbl(A) = Dossier & ItemVu
                End If
            End If
            ItemVu = Dir()
        Loop
    Else
        Err.Clear
    End If
    'examen des sub dossier
    For Each subdossier In SubFolderCollection
        A = UBound(tbl) + 1: ReDim Preserve tbl(1 To A): tbl(A) = Dossier & subdossier
        DirList Dossier & subdossier & "\", True, tbl
    Next subdossier
    DirList = tbl
End Function

pour info chez moi un dossier avec des sous sous sous dossiers en pagaille et pas moins de 5000 fichiers je met moins de 3 secondes pour les lister sur la feuille
a toi de tester maintenant

 

[Akortys]

Effectivement après test cela met 1 seconde en arrondissant

 

[patricktoulon]

bon!!!! a la bonne heure
donc maintenant il sagit de récupérer la [D2] des ces foutus fichiers on est d'accords ?

 

[patricktoulon]

bon à tester
pour info chez moi moins de 3 secondes pour 5000 fichier éparpillés dans une foultitude de sous dossiers
ici on recupere D2 de Feuil1

Sub testXy()
    Cells.Clear
    Dim liste As Variant
    liste = DirList("G:\vba excel\")
    Cells(1, 1).Resize(UBound(liste(0)), 1).Value = Application.Transpose(liste(0))
    Cells(1, 2).Resize(UBound(liste(1)), 1).Value = Application.Transpose(liste(1))


End Sub

Function DirList(Dossier As String, Optional recall As Boolean = False, Optional tbl As Variant, Optional tblval As Variant) As Variant
    Dim ItemVu As String, directory As Variant, SubFolderCollection As Collection, I As Long, A As Long, E As Long
    Set SubFolderCollection = New Collection
    If recall = False Then ReDim tbl(0): ReDim tblval(0)   ' si recall  on redim un tableau  de zero item (pour la creation du tableau)
    On Error Resume Next    'gestion des fichiers dossiers system et interdit ou generant une erreur(PerLog,recycle,etc..)
    ItemVu = Dir(Dossier, vbDirectory)
    If Error.Number = 0 Then    ' si pas d'erreur on examine le contenu
        'examen  du dossier courrant
        Do Until ItemVu = vbNullString
            If Left(ItemVu, 1) <> "." Then
                If (GetAttr(Dossier & ItemVu) And vbDirectory) = vbDirectory Then
                    SubFolderCollection.Add ItemVu
                Else
                    If Right(ItemVu, 5) Like ".xls*" Then
                        A = UBound(tbl) + 1
                        ReDim Preserve tbl(1 To A): tbl(A) = Dossier & ItemVu
                        argument = "'" & Dossier & "[" & ItemVu & "]Feuil1'!" & Range("D2").Address(, , xlR1C1)
                        ReDim Preserve tblval(1 To A): tblval(A) = ExecuteExcel4Macro(argument)
                      
                    End If
                End If
            End If
            ItemVu = Dir()
        Loop
    Else
        Err.Clear
    End If
    'examen des sub dossier
    For Each subdossier In SubFolderCollection
        'A = UBound(tbl) + 1: ReDim Preserve tbl(1 To A): tbl(A) = Dossier & subdossier
        DirList Dossier & subdossier & "\", True, tbl, tblval
    Next subdossier
    DirList = Array(tbl, tblval)
End Function

 

[patricktoulon]

alors ça décoiffe ou pas ?

 

[patricktoulon]

bon je pars en inter sur chantier je reviens plus tards
bon test

 

[Akortys]

alors ça décoiffe ou pas ?

Faut que je teste j'étais parti en réunion. Je m'occupe de ça et reviens vers toi dès que possible.

Mais ce n'est pas si simple que de récupérer une valeur et de la mettre dans une colonne d'un autre fichier. J'eesaie de retranscrire cela en français et reviens par la suite

En merci pour tes actions rapides en tout cas

 

[Akortys]

J'ai essayé ton code mais ça n'a pas l'air de fonctionner, où en cas ça ne fonctionnepas comme je le souhaite.

Alors pour expliquer le code.

Dans le fichier source (celui où la macro s'exécute).
On ne supprime pas les données de ce fichier, on vient seulement remplacer les valeurs parce celles exécuter dans la macro ou en ajouter.

RepertoireDeTravail = répertoire fichier qui contient macro

BOUCLE A FAIRE sur les lignes :

• On prend l'information de la colonne C+ligne2,
• FichierCherche = Fichier recherché : valeur de c2 + ".csv"
• On prend l'information de la colonne H+ligne2 si vide alors on prend information de la colonne F+ligne2 =>>> variable DebutNom
• On recherche FichierCherche dans RepertoireDeTravail & "\machines"
• Si pas de fichier trouvé, on met dans la colonne N+ligne2 "Pas de fichiers Machine trouvé"
• Si fichier trouvé, on récupére la valeur de la colonne D pour la ligne 2 (variable DonneeSource par exemple),
• On se positionne sur le fichier source, et on vient coller la valeur DebutNom & "_" & DonneeSource dans colonne N + ligne2

Après j'ai d'autres copies simples à faire mais je maitrise la simplicité