Microsoft 365 Optimiation de macro

Akortys

Akortys

XLDnaute Occasionnel
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
 

Pièces jointes

  • Client-MachineA_RENSEIGNER.xlsm
    108.9 KB · Affichages: 37
Trier par date Trier par votes
Akortys

Akortys

XLDnaute Occasionnel
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
 
Vote positif 0 Vote négatif
Dudu2

Dudu2

XLDnaute Barbatruc
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
 
Dernière édition:
Vote positif 0 Vote négatif
Akortys

Akortys

XLDnaute Occasionnel
erreur.png
 
Vote positif 0 Vote négatif
Dudu2

Dudu2

XLDnaute Barbatruc
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
 
Dernière édition:
Vote positif 0 Vote négatif
Akortys

Akortys

XLDnaute Occasionnel
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.
 
Vote positif 0 Vote négatif
Dudu2

Dudu2

XLDnaute Barbatruc
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
 
Vote positif 0 Vote négatif
Dudu2

Dudu2

XLDnaute Barbatruc
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>
 
Vote positif 0 Vote négatif

Discussions similaires

F
  • Résolu(e)
XL 2010 Macro : Remplissage de texte sous conditions
Réponses
11
Affichages
205
FLG
F
A
  • Question
XL 2019 Modification d'une VBA ou Macro pour une recherche d'occurrence via les lois binomial ou calcul factoriel
2
Réponses
15
Affichages
781
Aeroberto0099bis
A
patricktoulon
  • Question
Autres que penses vous de ce mini test benchmark(timer plus precis)
Réponses
6
Affichages
326
patricktoulon
patricktoulon
L
  • Question
Microsoft 365 Faire agir une macro en fonction de l'emplacement du bouton
Réponses
2
Affichages
291
AtTheOne
AtTheOne
P
  • Question
XL 2016 comptage de cases contigües selon critères
2
Réponses
25
Affichages
1 K
PiLVaLK
P
J
  • Résolu(e)
Microsoft 365 Valeur Cible en Boucle
2
Réponses
19
Affichages
3 K
Jordan02
J
D
  • Question
XL 2019 Mon classeur a explosé ( énorme projet macro détruit par le "Partage de classeur" )
Réponses
2
Affichages
400
Staple1600
Staple1600
P
  • Résolu(e)
XL 2019 Améliorer voire accélérer une Macro
Réponses
6
Affichages
502
patricktoulon
patricktoulon
M
  • Résolu(e)
Microsoft 365 [Résolu] Macro extraction de dates
Réponses
6
Affichages
958
maxime45
M
M
  • Résolu(e)
Microsoft 365 Formulaire recherche qui plante - VBA
Réponses
3
Affichages
523
Mcmaldo
M

Membres actuellement en ligne

20 membres et 295 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
314 487
Messages
2 110 119
Membres
110 676
dernier inscrit
Hoolaurent