Accélérer une macro

Bonjour à tous,

Je me permets de vous solliciter pour vous demander conseil concernant une macro que j'ai créé.

La macro permet de copier toutes les feuilles d'un classeur puis de les coller dans un classeur central avec des feuilles model préexistantes.

Le problème est que la macro est trop lente, environ 2-3 minutes pour copier 20 feuilles. Je voulais donc savoir s'il était possible d'accélérer la macro.

J'ai déjà essayer screenupdating mais ça ne change pas grand chose.

Et deuxième problème, une fois que je n'ai plus de fichier dans mon dossier donc à la fin, j'ai un message d'erreur comme quoi le fichier n'existe pas, ça me met une erreur au niveau de "application.workbook" mais je ne sais pas à quoi cela est du.

Voici la macro:

Sub Macrote()

Application.DisplayAlerts = False

Dim CD As Workbook 'déclare la varaible CD (Classeur Destinsation)
Dim OD As Worksheet 'déclare la varaible OD (Onglet Destinsation)
Dim CA As String 'déclare la varaible CA (Chemin d'Accès)
Dim F As String 'déclare la varaible F (Fichier)
Dim CS As Workbook 'définit la variable CS (Classeur Source)
Dim OS As Worksheet 'déclare la variable OS (Onglet)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)
Dim J As Long ' déclare la variable J (Numéro de jours)
Dim Res As Integer

Set CD = ThisWorkbook 'définit le classeur destination CD
CA = CD.Path & "\" 'définit la chemin d'acces du dossier des fichiers source
F = Dir(CA & "*.xlsx") 'définit le premier fichier F avec extension .xlsx ayant CA comme chemin d'accès (extension à adapter)
Res = ThisWorkbook.Worksheets(1).Range("A1")

Do While F <> ThisWorkbook.Name And F Like "*.xlsx"
   For J = Res To ThisWorkbook.Worksheets.Count
        Application.Workbooks.Open (CA & F), UpdateLinks:=0 'ouvre le fichier F
        Set CS = ActiveWorkbook 'définit le classeur CS
        Set OS = CS.Sheets(1) 'définit l'onglet OS
        OS.Range("A1:AK50").Copy  'copie les données de l'onglet source OS 
        ThisWorkbook.Sheets(J).Activate
        Range("A1").Activate
        Range("A1").Select
        Range("A1").PasteSpecial xlPasteValues, xlPasteSpecialOperationNone
        ThisWorkbook.Sheets("Model").Activate
        Cells.Activate
        Cells.Select
        Cells.Copy
        ThisWorkbook.Sheets(J).Activate
        Range("A1").Activate
        Range("A1").Select
        Range("A1").PasteSpecial xlPasteFormats, xlPasteSpecialOperationNone
        Application.CutCopyMode = False

       CS.Close False
        Set CS = Nothing 'initialise la variable CS
        F = Dir 'définit le prochain fichier F ayant avec extension .xlsx ayant CA comme chemin d'accès
        Next J

Loop 'boucle

Application.DisplayAlerts = True
End Sub

Merci d'avance.

Bonjour,

Avant de me lancer, les feuilles de destination dans le fichier central sont créées d'avance, ou il faut les créer au fur et à mesure, en fonction du nombre d'onglet à rapatrier ?

Je ne suis pas sur de bien saisir le concept, au regard du code... Il faut rapatrier les données de tous les onglets présents dans chaque fichier source, ou seulement du 1er onglet ?

Bonjour Pedro et merci d'avoir prit le temps de répondre.

En effet les feuilles de destination dans le fichier central sont créées d'avance.

Il y a 3 équipes par jour donc les feuilles se nomment :

-Lun A

-Lun B

-Lun C et ainsi de suite.

Chaque classeur source dispose d'une seule feuille nommé "déclaration". Le nom du classeur est en fonction du jour jjmmaaaA ou B ou C.

Ils sont dans l'ordre dans le dossier source donc je les prends un par un et les colle dans un onglet Lun A ou Lun B ou Lun C et ainsi de suite dans le classeur central.

Merci d'avance.

Du coup, comment fait-on pour savoir où coller les données issues de chaque fichier source dans le classeur de destination pour ne pas écraser les données précédentes ?

Concrètement dans votre code, vous avez actuellement une boucle sur les feuilles du fichier de destination, de "Res" à la dernière, et pour chaque fichier ouvert, vous collez les données en A1 de chacune de ces feuilles. Au final, il n'y aura donc que les données du dernier fichier ouvert dans chacun de ces onglets.

Tout ça pour dire que la logique n'est pas claire, et qu'il faut bien la détailler pour que le code s'applique correctement.

Je vous envoie tous les fichiers.

Mettez le tout dans un dossier et ensuite ouvrez le fichier HMO S et allez sur la premiere feuille.

Merci d'avance.

Si j'ai bien compris le principe, l'onglet de destination peut être déterminé à partir du nom du fichier source. J'ai retravaillé votre code, voilà ce que je propose :

Sub Macrote2()

Dim CA As String 'déclare la variable CA (Chemin d'Accès)
Dim F As String 'déclare la varaible F (Fichier)
Dim CS As Workbook 'définit la variable CS (Classeur Source)
Dim OS As Worksheet 'déclare la variable OS (Onglet)
Dim J As String ' déclare la variable J

Application.DisplayAlerts = False 'Désactive les messages d'alerte
Application.ScreenUpdating = False 'Désactive l'affichage
Application.Calculation = xlCalculationManual 'Désactive le recalcul auto des formules

On Error Resume Next 'En cas d'erreur, passe à l'instruction suivante
With ThisWorkbook 'Tout ce qui commence par un "." s'y rapporte
    CA = .Path & "\" 'définit la chemin d'acces du dossier des fichiers source
    F = Dir(CA & "*.xlsx") 'définit le premier fichier F avec extension .xlsx ayant CA comme chemin d'accès (extension à adapter)
    Do While Len(F) > 0
        Set CS = Workbooks.Open(CA & F, 0) 'ouvre le fichier F
        Set OS = CS.Sheets(1) 'définit l'onglet OS
        J = Replace(CS.Name, ".xlsx", "") 'Récupère le nom du classeur seul
        If J Like "########?" Then 'Si le nom correspond au format désiré (date + lettre)
            J = Choose(Weekday(DateSerial(Mid(J, 5, 4), Mid(J, 3, 2), Mid(J, 1, 2))), "Dim ", "Lun ", "Mar ", "Mer ", "Jeu ", "Ven ", "Sam ") & UCase(Mid(J, 9, 1)) 'Identifie le nom de la feuille de destination
            OS.Range("A1:AK50").Copy 'Copie les données
            .Sheets(J).Range("A1").PasteSpecial xlPasteValues
            .Sheets("Model").Cells.Copy 'Applique le format modèle
            .Sheets(J).Range("A1").PasteSpecial xlPasteFormats
            Application.CutCopyMode = False
        End If
        CS.Close False 'Ferme le fichier source
        F = Dir() 'définit le prochain fichier F
    Loop 'boucle
End With

Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

Tout d'abord je te remercie énormément, le programme est très très rapide.

Le seul problème est qu'il ne commence pas au bon jour. Sur mon lundi j'ai les samedis et lundi ne commence qu'à parti de mardi du coup tout est décalé.

Je me demande si c'est à cause de

"J = Choose(Weekday(DateSerial(Mid(J, 5, 4), Mid(J, 3, 2), Mid(J, 1, 2))), "Dim ", "Lun ", "Mar ", "Mer ", "Jeu ", "Ven ", "Sam ") & UCase(Mid(J, 9, 1)) 'Identifie le nom de la feuille de destination" comme je n'ai pas de dimanche dans la semaine que je viens de tester.

Et le nom de ma feuille source est AAAAMMJJ(avec l'équipe à la fin) mais j'imagine que ça ne doit pas changer quelque chose.

Merci d'avance.

Bonjour Zalee, Pedro22,

Si le Format est "AAAAMMJJ" sa change la valeur de "J", mais je ne comprends pas, d'après vos exemple de fichier le format est plus de type "JJMMAAAA" , vous avez de format entre temps ?

Si le format des fichier est de ce type "AAAAMMJJ":

J = Choose(Weekday(DateSerial(Mid(J, 1, 4), Mid(J, 5, 2), Mid(J, 7, 2))), "Dim ", "Lun ", "Mar ", "Mer ", "Jeu ", "Ven ", "Sam ") & UCase(Mid(J, 9, 1)) 'Identifie le nom de la feuille de destination

J'ai ajouté un paramètre pour préciser que les semaines débutent au lundi. Tu peux remplacer la ligne actuelle par celle-ci :

J = Choose(Weekday(DateSerial(Mid(J, 5, 4), Mid(J, 3, 2), Mid(J, 1, 2)), vbMonday), "Lun ", "Mar ", "Mer ", "Jeu ", "Ven ", "Sam ", "Dim ") & UCase(Mid(J, 9, 1))

Edit : salut Florian ! Très juste, la macro transmise se base sur une date au format JJMMAAAA dans le nom des fichiers source, et doit être adaptée si le format de date diffère.

Merci Florian et merci Pedro, en effet les fichiers sont de type AAAAMMJJ, j'ai fait une erreur.

Cette formule commence le lundi dans l'onglet Ven A

J = Choose(Weekday(DateSerial(Mid(J, 1, 4), Mid(J, 5, 2), Mid(J, 5, 2)), vbMonday), "Dim ", "Mar ", "Mer ", "Jeu ", "Ven ", "Sam ", "Lun ") & UCase(Mid(J, 9, 1))

Ces formules collent seulement mon lundi équipe A dans tous les onglets.

 J = Choose(Weekday(DateSerial(Mid(J, 1, 4), Mid(J, 5, 2), Mid(J, 5, 2)), vbMonday), "Lun ", "Mar ", "Mer ", "Jeu ", "Ven ", "Sam ", "Dim ") & UCase(Mid(J, 9, 1))

J = Choose(Weekday(DateSerial(Mid(J, 5, 4), Mid(J, 3, 2), Mid(J, 1, 2)), vbMonday), "Lun ", "Mar ", "Mer ", "Jeu ", "Ven ", "Sam ", "Dim ") & UCase(Mid(J, 9, 1))

Je vous avouerais que je suis largué.

Merci d'avance.

Dans ce cas, faites une pause sur votre macro principale.

L'idée est de créer une macro de test pour contrôler pas à pas les valeurs renvoyées par les extraits de code ci-dessous. Ceci permet d'une part de comprendre comment ça fonctionne, et d'autre part, d'où proviennent les éventuelles erreurs.

Voilà un fichier de test avec ladite macro :

Avec cette méthode, on se rend facilement compte que dans les 2 premières syntaxes de votre message, le mois et le jour sont identiques par exemple.
Mais aussi que vous n'avez pas repris le bon ordre des jours dans la première fonction Choose, puisque le premier est "Dim " et non pas "Lun ", et que "Lun" a disparu en fin de liste, donc on passe de dimanche à mardi, et de samedi à lundi ! Enfin, la dernière syntaxe est correcte pour une date formatée ainsi : JJMMAAAA.

Je vous laisse retenir la bonne syntaxe avec ces éléments, ou nous revenir en cas de pépin !

PS : pour info, la fonction VBA Mid(Chaine, CarDébut, NbCar) équivaut à la fonction Excel STXT(Chaine; CarDébut; NbCar). Elle permet d'extraire NbCar caractères d'une chaine de caractère, en commençant par le caractère située en position CarDébut.

Merci beaucoup Pedro pour toutes ces informations, vraiment c'est très gentil de votre part.

J'essaie de voir ça ce weekend et je vous tien au courant :)

un grand merci à vous j'ai trouvé le code, effectivement ça ne demandait pas énormément de réflexe mais je ne connaissais pas les formules Mid.

Voici la formule entière:

Sub Macrote2()

Dim CA As String 'déclare la variable CA (Chemin d'Accès)
Dim F As String 'déclare la varaible F (Fichier)
Dim CS As Workbook 'définit la variable CS (Classeur Source)
Dim OS As Worksheet 'déclare la variable OS (Onglet)
Dim J As String ' déclare la variable J

Application.DisplayAlerts = False 'Désactive les messages d'alerte
'Application.ScreenUpdating = False 'Désactive l'affichage
Application.Calculation = xlCalculationManual 'Désactive le recalcul auto des formules

On Error Resume Next 'En cas d'erreur, passe à l'instruction suivante
With ThisWorkbook 'Tout ce qui commence par un "." s'y rapporte
    CA = .Path & "\" 'définit la chemin d'acces du dossier des fichiers source
    F = Dir(CA & "*.xlsx") 'définit le premier fichier F avec extension .xlsx ayant CA comme chemin d'accès (extension à adapter)
    Do While Len(F) > 0
        Set CS = Workbooks.Open(CA & F, 0) 'ouvre le fichier F
        Set OS = CS.Sheets(1) 'définit l'onglet OS
        J = Replace(CS.Name, ".xlsx", "") 'Récupère le nom du classeur seul
        If J Like "########?" Then 'Si le nom correspond au format désiré (date + lettre)
            J = Choose(Weekday(DateSerial(Mid(J, 1, 4), Mid(J, 5, 2), Mid(J, 7, 2)), vbMonday), "Lun ", "Mar ", "Mer ", "Jeu ", "Ven ", "Sam ", "Dim ") & UCase(Mid(J, 9, 1)) 'Identifie le nom de la feuille de destination
            OS.Range("A1:AK50").Copy 'Copie les données
            .Sheets(J).Range("A1").PasteSpecial xlPasteValues
            .Sheets("Model").Cells.Copy 'Applique le format modèle
            .Sheets(J).Range("A1").PasteSpecial xlPasteFormats
            Application.CutCopyMode = False
        End If
        CS.Close False 'Ferme le fichier source
        F = Dir() 'définit le prochain fichier F
    Loop 'boucle
End With

Application.DisplayAlerts = True
'Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

Si je peux me permettre, j'aimerais vous montrer un autre petit code. Le problème étant le même, je l'ai fait de manière un peu brut, serait-il possible d'améliorer celui-là ?

Il permet simplement de copier un tableau en décaler et de le coller dans une cellule mais comme c'est la première fois que j'ai utilisé offset et find je ne sais pas si il pourrait avoir une autre manière. Et ce que j'aimerais c'est de pouvoir intégrer la deuxième dans la première. Je sais que je devrais changer les variables mais à quel moment serait-il efficace de le mettre ?

Sub AMP()

Dim CD As Workbook 'déclare la varaible CD (Classeur Destinsation)
Dim OD As Worksheet 'déclare la varaible OD (Onglet Destinsation)
Dim RD As Range 'déclare la variable RD (Range destination de la feuille AMP)
Dim CA As String 'déclare la varaible CA (Chemin d'Accès)
Dim F As String 'déclare la varaible F (Fichier)
Dim CS As Workbook 'définit la variable CS (Classeur Source)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim DS As String 'déclare le dossier source
Dim PlageDeRecherche As Range 'déclare la variable RS (Range source du fichier pointage AMP)
Dim Trouve As Range '
Dim Sem As Worksheet '
Dim Valeur_Cherchee As String
Dim AdresseTrouvee As String
Dim Dealer_name As Range

Set CD = ThisWorkbook 'définit le classeur destination CD
Set OD = CD.Worksheets("AMP")

CA = "C:\Users\Documents\Suivi\" 'définit la chemin d'acces du dossier des fichiers source
F = "POINTAGE.xlsm"
DS = (CA & F)

Workbooks.Open DS
Set CS = ActiveWorkbook
Set OS = CS.Worksheets("AMP")
Set PlageDeRecherche = OS.Columns("D")
Set Sem = CD.Worksheets("AMP")
Valeur_Cherchee = Sem.Range("D3")
Set Trouve = PlageDeRecherche.Cells.Find(Valeur_Cherchee, , xlValues, xlWhole)

    If Trouve Is Nothing Then
        AdresseTrouvee = Valeur_Cherchee & " n'est pas présent dans " & PlageDeRecherche.Address

    Else

        Range(Trouve.Address).Offset(1, 36).Select
        ActiveCell.Resize(9, 14).Select
        Selection.Copy
        ThisWorkbook.Sheets("AMP").Activate
        Range("E4:R12").Activate
        Range("E4:R12").Select
        Range("E4").PasteSpecial xlPasteValues, xlPasteSpecialOperationNone
        Application.CutCopyMode = False

    End If

CS.Close False

End Sub

Merci d'avance.

Bonjour,

Plutôt que de te proposer un code clé en main, je te propose plutôt de commenter tes essais.

Concernant celui-ci, tu peux te simplifier la vie, plutôt que de déclarer des variables en cascade que tu n'utilises ensuite qu'une fois ou deux. Exemple :

Sub Démo1()
'Non simplifié
Dim Classeur As Workbook
Dim Feuille As Worksheet
Dim Plage As Range

Set Classeur = ThisWorkbook
Set Feuille = Classeur.Worksheets(1)
Set Plage = Feuille.Range("A1:A100")

End Sub
Sub Démo2()
'Simplifié
Dim Plage As Range

Set Plage = ThisWorkbook.Worksheets(1).Range("A1:A100")

End Sub

A noter que si tu n'as pas ouvert d'autre classeur, ThisWorkbook est implicite et il est inutile de le préciser. Dans le même goût, en l'absence de précision, VBA se basera sur ActiveSheet (la feuille active) pour déterminer la feuille parente d'une plage.

Autre point, dans l'immense majorité des cas, .Select et .Activate sont inutiles. Il suffit de préciser les objets utilisés (comme dans le code exemple ci-dessus), sans nécessit" de les "voir" (.Activate) ou les "toucher" (.Select) comme on le ferait en temps qu'utilisateur :

'Ecriture actuelle :

Range(Trouve.Address).Offset(1, 36).Select
ActiveCell.Resize(9, 14).Select
Selection.Copy
ThisWorkbook.Sheets("AMP").Activate
Range("E4:R12").Activate
Range("E4:R12").Select
Range("E4").PasteSpecial xlPasteValues, xlPasteSpecialOperationNone
Application.CutCopyMode = False

'Ecriture révisée :
Range(Trouve.Address).Offset(1, 36).Resize(9, 14).Copy
ThisWorkbook.Sheets("AMP").Range("E4:R12").PasteSpecial xlPasteValues, xlPasteSpecialOperationNone
Application.CutCopyMode = False

Bon eh bien je vois que j'ai le droit à un cours privé :)

Je fais ça ce soir et je vous renvoie le résultat.

Encore merci.

Bon j'ai fait ce que j'ai pu mais il y a une chose dont je n'ai pas dit c'est qu'il y a deux documents et non un seul.

Donc je copie le tableau dans un document nommé AMP et colle dans mon Classeur HMO S.

Sub AMP()

Dim CD As Worksheet 'déclare la varaible CD (Classeur Destinsation)
Dim CA As String 'déclare la varaible CA (Chemin d'Accès)
Dim F As String 'déclare la varaible F (Fichier)
Dim CS As Workbook 'définit la variable CS (Classeur Source)
Dim DS As String 'déclare le dossier source
Dim OS As Worksheet
Dim PlageDeRecherche As Range 'déclare la variable RS (Range source du fichier pointage AMP)
Dim Trouve As Range
Dim Valeur_Cherchee As String
Dim AdresseTrouvee As String

Set CD = ThisWorkbook.Worksheets("AMP") 'définit le classeur destination CD
CA = "G:\Doc\Documents\POINTAGE\" 'définit la chemin d'acces du dossier des fichiers source
F = "AMP.xlsm"
DS = (CA & F)
Workbooks.Open DS
Set CS = ActiveWorkbook
Set OS = CS.Worksheets("AMP")
Set PlageDeRecherche = OS.Columns("D")
Valeur_Cherchee = 1 'ThisWorkbook.Worksheets("Sem").Range("D3")
Set Trouve = PlageDeRecherche.Cells.Find(Valeur_Cherchee, , xlValues, xlWhole)
    If Trouve Is Nothing Then
     AdresseTrouvee = Valeur_Cherchee & " n'est pas présent dans " & PlageDeRecherche.Address
    Else
        Range(Trouve.Address).Offset(1, 36).Resize(9, 14).Copy
        With ThisWorkbook.Sheets("AMP").Range("E4:R12")
        .PasteSpecial xlPasteValues
        .PasteSpecial xlPasteFormats
        Application.CutCopyMode = False
        End With
    End If
CS.Close False
End Sub

Merci pour ton aide.