Microsoft 365 Optimiation de macro

Akortys · 7 Septembre 2020

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

Akortys · 8 Septembre 2020

Dudu2 à dit:
'C'est quoi cet horrible -11 ?
RepertoireDeTravail = Left(RepertoireDeTravail, (Len(RepertoireDeTravail) - 11))

En fait c'est pour récupérer le dossier parent de equipement. Il y a peut être mieux à faire je pense. Mais je ne sais pas pour le moment

Akortys · 8 Septembre 2020

VB:

Workbooks.Open Filename:=RepertoireDeTravail & "\equipement\Client-MachineImportIsdxXls.xls", local:=True
    
    Windows(ThisWorkbook.Name).Activate
    ActiveSheet.Columns("A:L").Copy
    
    Windows("Client-MachineImportIsdxXls.xls").Activate
    ActiveSheet.Columns("A:A").Paste

J'ai une erreur à ce niveau sur la dernière ligne de code. au moment du paste

Dudu2 · 8 Septembre 2020

Pour le dossier parent tu peux / dois faire:

Code:

RepertoireDeTravail = Left(RepertoireDeTravail, InStrRev(RepertoireDeTravail, "\") - 1)

Pour l'erreur du Paste, j'ai pas trop regardé cette partie. Perso je mettrais les même Ranges.
Remplace la fonction par ce code que j'ai modifié.

Code:

Sub MiseAJour()
    Dim i As Long
    Dim j As Long
    Dim jMax As Long
    Dim RépertoireDeTravail As String
    Dim NomFichierRecherché As String
    Dim DésignationMachine As String
    Dim NuméroDeSérie As String
    
    'Definition du repertorie de travail
    RépertoireDeTravail = ActiveWorkbook.Path
    RépertoireDeTravail = Left(RépertoireDeTravail, InStrRev(RépertoireDeTravail, "\") - 1)
    
    '1 pour le fichier, 2 pour le répertoire / 0 inutilisé, juste pour avoir une dimension
    ReDim TabFichiersRépertoiresCSV(1 To 2, 0 To 0)
    
    'Chargement des noms de fichiers CSV et leurs répertoires en table
    Call ParcoursRépertoire(RépertoireDeTravail)

    Application.ScreenUpdating = False
    
    'Retirer les filtres pour que le compte soit correct
    If Not ActiveSheet.AutoFilter Is Nothing Then ActiveSheet.AutoFilter.ShowAllData
    'Calcul du nombre de lignes a traiter
    jMax = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row

    'Recherche de la DésignationMachine et inscription en colonne N
    For j = 2 To jMax
        'recupération du code machine
        NomFichierRecherché = UCase(Trim(ActiveSheet.Range("C" & j).Value)) & ".CSV"
        
        For i = 1 To UBound(TabFichiersRépertoiresCSV, 2)
            If TabFichiersRépertoiresCSV(1, i) = NomFichierRecherché Then Exit For
        Next i
        
        'Fichier trouvé
        If i <= UBound(TabFichiersRépertoiresCSV, 2) Then
            'récupération du numéro de série (si vide, on prend le num de reconditionnement
            NuméroDeSérie = Range("H" & j).Value
            If NuméroDeSérie = "" Then NuméroDeSérie = Range("F" & j).Value
            
            DésignationMachine = ExtraireValeurFichierCSV(TabFichiersRépertoiresCSV(2, i), TabFichiersRépertoiresCSV(1, i), 2, 4, ";")
            Range("N" & j).Value = NuméroDeSérie & "_" & DésignationMachine
        Else
            ActiveSheet.Range("N" & j).Value = "PAS DE FICHIER MACHINE TROUVE"
        End If
    Next j
    
    'copy des information dans les deux autres fichiers Excel
    Workbooks.Open Filename:=RépertoireDeTravail & "\equipement\Client-MachineImportIsdxXls.xls", local:=True
    
    Windows(ThisWorkbook.Name).Activate
    ActiveSheet.Columns("A:L").Copy
    
    Windows("Client-MachineImportIsdxXls.xls").Activate
    ActiveSheet.Columns("A:L").PasteSpecial xlPasteAll
    'ActiveSheet.PasteSpecial Paste:=xlPasteValues
    ActiveWorkbook.Save
    ActiveWorkbook.Close
    
    Workbooks.Open Filename:=RépertoireDeTravail & "\equipement\Client-Machine.xlsx", local:=True
    
    Windows(ThisWorkbook.Name).Activate
    ActiveSheet.Range("A2", "E" & jMax).Copy
    
    Windows("Client-Machine.xlsx").Activate
    ActiveSheet.Range("A2", "E" & jMax).PasteSpecial xlPasteAll
    ActiveWorkbook.Save
    ActiveWorkbook.Close
    
    Windows(ThisWorkbook.Name).Activate

    Application.ScreenUpdating = True
        
    MsgBox "MISE A JOUR TERMINE"   
End Sub

Akortys · 8 Septembre 2020

c'est quoi ça :

VB:

WS.AutoFilter.ShowAllData

parce que j'ai une erreur dessus.
Erreur de compilation variable non définie

Dudu2 · 8 Septembre 2020

Oui, je sais, j'ai corrigé.
Reprends le code de la fonction au message #33.

Akortys · 8 Septembre 2020

Dudu2 · 8 Septembre 2020

Ok apparemment faut faire un Select...

VB:

Columns("A:A").Select
ActiveSheet.Paste

J'ai corrigé le code de la fonction en message #33

Dudu2 · 8 Septembre 2020

Il y a plusieurs façons de Copier / Coller en VBA.
- Le Copier peut se faire sur une feuille active ou sur n'importe quelle feuille d'un classeur non actif.
- Le Coller peut sur faire sur une feuille active ou sur n'importe quelle feuille d'un classeur non actif.

Pour Copier:
<Classeur source>.<Feuille source>.<Plage>.Copy

Pour Coller 3 méthodes (à ma connaissance):
1 -
- <Classeur cible>.Activate
- <Feuille cible>.Activate
- <1ère cellule cible>.Select
- ActiveSheet.Paste

2 -
Ajouter l'option Destination au Copy
<Classeur source>.<Feuille source>.<Plage>.Copy _
Destination:=<Classeur cible>.<Feuille cible>.<1ère cellule cible>

3 -
<Classeur cible>.<Feuille cible>.<1ère cellule cible>.PasteSpecial xlPasteAll (ou autre option)

Code:

Sub a()
    'Copier
    Windows("Classeur2").Activate
    ActiveWorkbook.Worksheets(1).Activate
    ActiveSheet.Columns("A:J").Copy
    'Coller
    Windows("Classeur1").Activate
    ActiveWorkbook.Worksheets(1).Activate
    ActiveSheet.Range("A1").Select
    ActiveSheet.Paste
End Sub

Sub aa()
    'Copier
    Workbooks("Classeur2").Worksheets(1).Columns("A:J").Copy
    'Coller
    Windows("Classeur1").Activate
    ActiveWorkbook.Worksheets(1).Activate
    ActiveSheet.Range("A1").Select
    ActiveSheet.Paste
End Sub

Code:

Sub a()
    Windows("Classeur2").Activate
    ActiveWorkbook.Worksheets(1).Activate
    'Copier / Coller
    ActiveSheet.Columns("A:J").Copy _
                               Destination:=Workbooks("Classeur1").Worksheets(1).Range("A1")
End Sub

Sub aa()
    Windows("Classeur3").Activate
    'Copier / Coller
    Workbooks("Classeur2").Worksheets(1).Columns("A:J").Copy _
                               Destination:=Workbooks("Classeur1").Worksheets(1).Range("A1")
End Sub

Code:

Sub a()
    Windows("Classeur2").Activate
    ActiveWorkbook.Worksheets(1).Activate
    'Copier
    ActiveSheet.Columns("A:J").Copy
    'Coller special
    Workbooks("Classeur1").Worksheets(1).Range("A1").PasteSpecial xlPasteAll
End Sub

Sub aa()
    Windows("Classeur3").Activate
    'Copier
    Workbooks("Classeur2").Worksheets(1).Columns("A:J").Copy
    'Coller special
    Workbooks("Classeur1").Worksheets(1).Range("A1").PasteSpecial xlPasteAll
End Sub

Akortys · 8 Septembre 2020

Merci pour tout mais je sens qu'il faille un dernier effort.

En fait cette partie de code a été zappé. Du coup j'essaie de la réadapter en fonction du travail que tu as déjà réalisé mais sans succès.

VB:

    'copy des information dans les deux autres fichiers Excel
    
    Workbooks.Open Filename:= _
            RepertoireDeTravail & "\equipement\Client-MachineImportIsdxXls.xls", local:=True
    
    Windows("Client-MachineA_RENSEIGNER.xlsm").Activate
    Columns("A:N").Select
    Selection.Copy
    Windows("Client-MachineImportIsdxXls.xls").Activate
    Columns("A:A").Select
    ActiveSheet.Paste
    'FC-Ajout du nouveau N°de série 29062020 dans le fichier Client-MachineImportIsdxXls.xls
    Windows("Client-MachineA_RENSEIGNER.xlsm").Activate
    Range("O2", "O" & jMax).Select
   Selection.Copy
    Windows("Client-MachineImportIsdxXls.xls").Activate
    Range("E2", "E" & jMax).Select
    ActiveSheet.Paste
    'FC-Fin ajout 29062020
    'ActiveSheet.PasteSpecial Paste:=xlPasteValues
    ActiveWorkbook.Save
    ActiveWorkbook.Close
    
    Windows("Client-MachineA_RENSEIGNER.xlsm").Activate
    
        
    Workbooks.Open Filename:= _
            RepertoireDeTravail & "\equipement\Client-Machine.xlsx", local:=True
    
    Windows("Client-MachineA_RENSEIGNER.xlsm").Activate
    Range("A2", "E" & jMax).Select
    Selection.Copy
    Windows("Client-Machine.xlsx").Activate
    Range("A2").Select
    ActiveSheet.Paste
    'FC-Ajout du nouveau N° de série 29062020 dans le fichier Client-Machine.xlsx
    Windows("Client-MachineA_RENSEIGNER.xlsm").Activate
    Range("O2", "O" & jMax).Select
   Selection.Copy
    Windows("Client-Machine.xlsx").Activate
    Range("E2", "E" & jMax).Select
    ActiveSheet.Paste
    'FC-Fin ajout 29062020
    ActiveWorkbook.Save
    ActiveWorkbook.Close
    
    Windows("Client-MachineA_RENSEIGNER.xlsm").Activate

Pourtant je ne pense pas que cela soit compliqué mais je crois que mes yeux ne répondent plus si ce n'est mon cerveau.

Dudu2 · 8 Septembre 2020

VB:

'copy des information dans les deux autres fichiers Excel
    
    Workbooks.Open Filename:=RepertoireDeTravail & "\equipement\Client-MachineImportIsdxXls.xls", local:=True
    Windows(ThisWorkbook.Name).Activate
    ActiveSheet.Columns("A:N").Copy
    Windows("Client-MachineImportIsdxXls.xls").Activate
    ActiveSheet.Columns("A:A").Select
    ActiveSheet.Paste
    
    'FC-Ajout du nouveau N°de série 29062020 dans le fichier Client-MachineImportIsdxXls.xls
    Windows(ThisWorkbook.Name).Activate
    ActiveSheet.Range("O2", "O" & jMax).Copy
    Windows("Client-MachineImportIsdxXls.xls").Activate
    ActiveSheet.Range("E2").Select
    ActiveSheet.Paste
    'FC-Fin ajout 29062020
    'ActiveSheet.PasteSpecial Paste:=xlPasteValues
    ActiveWorkbook.Save
    ActiveWorkbook.Close
        
    Workbooks.Open Filename:=RepertoireDeTravail & "\equipement\Client-Machine.xlsx", local:=True
    
    Windows(ThisWorkbook.Name).Activate
    ActiveSheet.Range("A2", "E" & jMax).Copy
    Windows("Client-Machine.xlsx").Activate
    Range("A2").Select
    ActiveSheet.Paste
    
    'FC-Ajout du nouveau N° de série 29062020 dans le fichier Client-Machine.xlsx
    Windows(ThisWorkbook.Name).Activate
    ActiveSheet.Range("O2", "O" & jMax).Copy
    Windows("Client-Machine.xlsx").Activate
    Range("E2").Select
    ActiveSheet.Paste
    'FC-Fin ajout 29062020
    ActiveWorkbook.Save
    ActiveWorkbook.Close
    
    Windows(ThisWorkbook.Name).Activate

Dudu2 · 8 Septembre 2020

A noter que lorsque tu ouvres un classeur, tu supposes toujours que la feuille cible est la feuille active.
Si un classeur a plusieurs feuilles, il peut très bien avoir été fermé sur n'importe laquelle de ses feuilles et c'est celle-là qui sera active à l'ouverture.
Donc ton système ne fonctionne à coup sûr que si tes classeurs cible n'ont qu'une seule feuille.

Si les classeurs cible ont plusieurs feuilles il serait bon:
- Soit d'activer la bonne feuille par son nom ou son numéro après l'ouverture du classeur
- Soit d'utiliser des .PasteSpecial xlPasteAll désignant <classeur>.<feuille>.<cellule cible>

Akortys · 8 Septembre 2020

EXCEPTIONNEL, tout à l'air de fonctionner..... Mille MERCI, je ne sais quoi dire à part un grand MERCI.
Quelle efficacité et réactivité.
A tester de fond en comble mais ça sent très bon......

Dudu2 · 8 Septembre 2020

Ok, si ça sent bon, c'est que Grasse n'est pas loin.
Pour info j'ai modifié mon cours magistral sur la Copier / Coller. A toutes fins utiles

Microsoft 365 Optimiation de macro

Akortys

XLDnaute Occasionnel

Pièces jointes

Akortys

XLDnaute Occasionnel

Akortys

XLDnaute Occasionnel

Dudu2

XLDnaute Barbatruc

Akortys

XLDnaute Occasionnel

Dudu2

XLDnaute Barbatruc

Akortys

XLDnaute Occasionnel

Dudu2

XLDnaute Barbatruc

Dudu2

XLDnaute Barbatruc

Akortys

XLDnaute Occasionnel

Dudu2

XLDnaute Barbatruc

Dudu2

XLDnaute Barbatruc

Akortys

XLDnaute Occasionnel

Dudu2

XLDnaute Barbatruc

Discussions similaires