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

P
  • Question
XL 2016 comptage de cases contigües selon critères
2
Réponses
25
Affichages
794
PiLVaLK
P
J
  • Résolu(e)
Microsoft 365 Valeur Cible en Boucle
2
Réponses
19
Affichages
2 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
309
Staple1600
Staple1600
P
  • Résolu(e)
XL 2019 Améliorer voire accélérer une Macro
Réponses
6
Affichages
366
patricktoulon
patricktoulon
M
  • Résolu(e)
Microsoft 365 [Résolu] Macro extraction de dates
Réponses
6
Affichages
866
maxime45
M
M
  • Résolu(e)
Microsoft 365 Formulaire recherche qui plante - VBA
Réponses
3
Affichages
441
Mcmaldo
M
Kinayla
  • Question
XL 2016 Supprimer un intervalle de 15minutes dans planning
2
Réponses
18
Affichages
1 K
TooFatBoy
TooFatBoy
S
  • Question
XL 2010 VBA - macro avec 1 boucle qui alterne 1 action à conditions et 1 action sans conditions
2 3 4
Réponses
58
Affichages
6 K
Scorp0211
S
S
  • Résolu(e)
XL 2016 VBA Tri de données
Réponses
6
Affichages
2 K
Serge6926
S
paradisecity1996
  • Question
XL 2019 BDD VBA - nombreux problèmes
Réponses
3
Affichages
630
fanfan38
fanfan38

Membres actuellement en ligne

21 membres et 199 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
312 271
Messages
2 086 686
Membres
103 370
dernier inscrit
pasval