Macro trop longue - optimisation code

Le 16/01/2025 à 10:41

bonjour,

l'ensemble de la macro sur un fichier de 2000 lignes dure beaucoup longtemps.

Auriez-vous des idées de simplification du code pour qu'elle soit plus rapide ?

Merci (beaucoup !) d'avance.

Et je suis désolé ça fait un moment que je ne suis pas venu sur le forum, je ne sais plus comment mettre en forme visula basic le code de la macro....

'créer une nouvelle feuille Suivi et insertion date
Sheets.Add
ActiveSheet.Name = "Suivi"
Sheets("Suivi").Activate
Range("A1").Value = "Date de l'extraction :"
Range("D1") = Date

'donne le chemin d'accès du fichier grandLivre
ChDir "C:\Perso\Divers\lydie\relances\V2"

Workbooks.Open Filename:="C:\Perso\Divers\lydie\relances\V2\Grand Livre.xlsx"
Windows("Grand Livre.xlsx").Activate
'Range("A1:I5000").Copy
Range("A4:I5000").Copy
Windows("2024-suivi-relances.xlsm").Activate
Sheets("Suivi").Range("A3").Select
ActiveSheet.Paste

Windows("Grand Livre.xlsx").Activate
Application.DisplayAlerts = False
Windows("Grand Livre.xlsx").Close
'SaveChanges:=False
ThisWorkbook.Worksheets("Suivi").Range("A3").Select

Columns("A:B").Copy
Columns("C:C").Insert Shift:=xlToRight

Range("F1").Cut
Range("C1").Select
ActiveSheet.Paste

Range("C3").Select
Selection.ClearContents

Range("A4") = "Numéro compte"
Range("B4") = "Client"

'suppression lignes en-tête :
For i = 5 To 4000
If Cells(i, 1) = "Total du Grand-Livre" Then
Exit For
ElseIf Cells(i, 1) = "COMPTA" Then
Range(Cells(i, 1), Cells(i + 5, 1)).EntireRow.Select
Selection.Delete
i = i - 1
End If
Next

Range("B5").Select

'copie des comptes
For i = 6 To 2000
If Cells(i, 1) = "Total du Grand-Livre" Then

Exit For
ElseIf Cells(i, 1) <> "Total " Then
Cells(i, 1) = Cells(i - 1, 1)
Cells(i, 2) = Cells(i - 1, 2)
ElseIf Cells(i, 1) = "Total " Then
i = i + 1
End If
Next

For i = 5 To 10000
If Cells(i, 1) = "Total du Grand-Livre" Then
Exit For
ElseIf Cells(i, 1) = "Total " Or Cells(i, 1) = Cells(i, 3) Then
Rows(i).Select
Selection.Delete Shift:=xlUp
i = i - 1

End If
Next

Range("B5").Select

Dim Vcellulebas
Dim Vplage
Dim Vnumeroligne
Dim Vplage1

Sheets("Suivi").Columns("A").Replace What:="Compte C", Replacement:="'", MatchCase:=True

Sheets("Suivi").Columns("A").Replace What:="Compte C", Replacement:="'", MatchCase:=True

For i = 5 To 5000
If Cells(i, 1) = "Total du Grand-Livre" Then
Rows(i + 1).Select
Selection.Delete Shift:=xlUp
Rows(i - 1).Select
Selection.Delete Shift:=xlUp
Cells(i - 1, 1).Select
Set Vcellulebas = ActiveCell
Vnumeroligne = ActiveCell.Row
Exit For
End If
Next

Columns("C:C").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

Range("C4") = "Signataire 1"
Range("D4") = "Signataire 2"
Range("E4") = "Resp. mission"
Range("F4") = "Code du groupe"

Columns("J:J").Delete

Range("O4") = "Commentaire"

Dim CheminComplet As String, NomClasseur As String, Plage As String, NomFeuil As String, Chemin As String

Plage = "$B$2:$H$5000" '<-- plage de recherche
NomFeuil = "A'!" '<-- nom de la feuille, ne pas oublier la simple cote avant le !
NomClasseur = "Table.xlsx" '<-- nom du classeur contenu dans la cellule E1
Chemin = "'C:\Perso\Divers\lydie\relances\V2\" '<-- emplacement sur le disque dur, ne pas oublier la simple cote avant la lettre de la partition

CheminComplet = Chemin & "[" & NomClasseur & "]" & NomFeuil & Plage

Range("C5").FormulaLocal = "=RECHERCHEV(A5;" & CheminComplet & ";3;FAUX)"
Range("D5").FormulaLocal = "=RECHERCHEV(A5;" & CheminComplet & ";4;FAUX)"
Range("E5").FormulaLocal = "=RECHERCHEV(A5;" & CheminComplet & ";5;FAUX)"
Range("F5").FormulaLocal = "=RECHERCHEV(A5;" & CheminComplet & ";6;FAUX)"
Range("O5").FormulaLocal = "=RECHERCHEV(A5;" & CheminComplet & ";7;FAUX)"

Columns("K:K").Delete

ThisWorkbook.Worksheets("Suivi").Range("C5:F5").Copy ThisWorkbook.Worksheets("Suivi").Range("C6:C" & Vnumeroligne)
ThisWorkbook.Worksheets("Suivi").Range("N5").Copy ThisWorkbook.Worksheets("Suivi").Range("N6:N" & Vnumeroligne)

Columns("A:N").EntireColumn.AutoFit

Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Range("A4:N4").Select
Selection.Font.Bold = True
Selection.Font.Underline = xlUnderlineStyleSingle
Selection.AutoFilter

Rows("5:5").Select
ActiveWindow.FreezePanes = True

Range("J5:L5").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.NumberFormat = "0.00"

Range("A2").Select

End Sub
Le 16/01/2025 à 10:44

Bonjour et bienvenue

je ne sais plus comment mettre en forme visula basic le code de la macro....

Il vous suffit de cliquer sur l'icone </> disponible dans la barre de menu et coller votre code dans la fenêtre.
J'ai corrigé pour que vous voyiez

1. Dans votre code vous avez cette instruction -->

Range("A4:I5000").Copy

Quel est le nom de l'onglet concerné ?

2. Dans quel fichier ajoutez-vous la feuille Suivi ? Celui qui contient la macro ?

Crdlt

edit : dans la boucle "Suppression entête", vous supprimez la ligne chaque fois que vous rencontrez "Compta" et tant que vous ne rencontrez pas "Total grand livre" ?
il y a plusieurs mots compte et total grand livre dans la colonne A ?

Cela serait plus pratique d'avoir les deux fichiers concernés (sans données confidentielles...)

Le 16/01/2025 à 11:22

Bonjour,

Rassurez-vous il y a beaucoup d'optimisations possibles sur votre macro. Après, comme indiqué par @Dan les fichiers seraient bienvenus.

Mais, il me semble que si je comprends bien le code, vous auriez intérêt à passer sur une requête PowerQuery. Le temps d'exécution sera similaire ou meilleur, mais surtout c'est moins sujet aux bugs. A voir si vos fichiers s'y prêtent.

Le 16/01/2025 à 11:48

Bonjour à tous,

Il y a surtout moyen d'éviter 4 boucles successives.

Espérons que Curulis passe par ici chasser les millisecondes

Le 16/01/2025 à 11:51

@21Formatic

Espérons que Curulis passe par ici chasser les millisecondes

Je ne sais pas comment interpréter le message ... Vous pensez que d'autres ne sont pas capables ?

Le 16/01/2025 à 12:04

Non, je faisais juste référence à cette discussion sur laquelle j'étais tombé récemment.

Ça fait plaisir de revenir ici et de voir que tout le monde est toujours aussi détendu et aussi peu susceptible !

Le 16/01/2025 à 12:05

merci pour toutes vos réponses si promptes. Vous l'avez compris, ce sont des données comptables donc confidentielles. Il faut donc que je retravaille les 3 fichiers (1 fichier de travail, 2 fichiers sources de données qui alimentent le fichier de travail) afin qu'aucune donnée confidentielle n'apparaisse, j'en ai pour un peu de temps... Je reviens sur le forum quand c'est prêt. En fait je cherchais surtout à optimiser mes boucles car le fichier de travail faisant environ 2000 lignes, les boucles sont super longues.

Le 16/01/2025 à 12:09

En fait je cherchais surtout à optimiser mes boucles car le fichier de travail faisant environ 2000 lignes, les boucles sont super longues.

Oui je l'ai vu dans votre code. Le premier souci à comprendre c'est pourquoi vous bouclez à 4 reprises ... car à chaque fois vous repartez depuis le début de votre feuille.
Pensez à montrer une feuille avec le résultat final attendu.

Le mieux serait de connaitre le nom du fichier dans lequel vous ajoutez la feuille Suivi et si le code se trouve bien dans ce fichier

Sinon, le début de votre code jusque la mention "Suppression des entêtes" pourrait être ceci
Attention à la variable Chemin qui est aussi déclarée plus bas dans votre code. Désactivez-la pour ne pas avoir de bug

Sub test()
Dim chemin As String, fichier As String

'créer une nouvelle feuille Suivi et insertion date
Sheets.Add
ActiveSheet.Name = "Suivi"
With Sheets("Suivi")
    .Range("A1").Value = "Date de l'extraction :"
    .Range("D1") = Date
End With

chemin = "C:\Perso\Divers\lydie\relances\V2\"
fichier = "Grand Livre.xlsx"

Workbooks.Open Filename:=chemin & fichier

With Workbooks(fichier)
    .ActiveSheet.Range("A4:I5000").Copy ThisWorkbook.Sheets("Suivi").Range("A3")
    .Close False
End With

With ThisWorkbook.Sheets("Suivi")
    .Columns("A:B").Copy
    .Columns("C:C").Insert Shift:=xlToRight
    .Range("F1").Cut .Range("C1")
    .Range("C3").ClearContents
    .Range("A4") = "Numéro compte"
    .Range("B4") = "Client"
End With

Edit : j'ai modifié chemin et fichier dans le code

Edit : @21Formatic : Pas de soucis

Rechercher des sujets similaires à "macro trop longue optimisation code"