Microsoft 365 Optimisation / accélération execution code VBA

Créer une discussion
Répondre
  • Initiateur de la discussion Initiateur de la discussion spike29
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
S

spike29

XLDnaute Occasionnel
Bonjour,

J'ai ci-dessous deux codes qui mettent assez longtemps à s'exécuter ( parfois plus d'une minute) et que je souhaiterai optimiser afin de gagner du temps d'execution.
Les .select y sont en partie pour quelque chose mais pas uniquement je pense.

Mes codes ci-dessous :

Le premier ci-dessous vient ouvrir un second fichier, y copie une partie des cellules vers le fichier initial, ferme le second fichier.
Il supprimer ensuite une ligne sur deux sur la copie venant d'être réalisée sur le fichier initial (mise en cohérence des données)
Puis recopie ces données mises en cohérence vers une autre feuille du classeur source.

VB: 
Sub Suivi()

  Application.ScreenUpdating = False
  Dim CD As Workbook, OD As Worksheet, BSF As FileDialog
  Dim fs As Byte, CS As Workbook, OS As Worksheet
  Dim FN As Byte
  Dim wb As Workbook
  Dim lig As Long
 
 
    With Application
    .ScreenUpdating = False
    .EnableEvents = False
  End With
 
 
 
  Sheets("Suivi").Unprotect Password:="sandman"

 
 
  Worksheets("Suivi").Range("A15:S5000").ClearContents

 

  Set CD = ThisWorkbook
  Set OD = CD.Worksheets(1)
  Set BSF = Application.FileDialog(msoFileDialogOpen)
  BSF.AllowMultiSelect = True
  BSF.Show
  If BSF.SelectedItems.Count = 0 Then Exit Sub
  For fs = 1 To BSF.SelectedItems.Count
    Application.Workbooks.Open (BSF.SelectedItems(fs))
    Set CS = ActiveWorkbook
    Set OS = CS.Worksheets(1)
     If Left(CS.Name, 10) = "Export" Then
       OS.Range("B14:I104").Copy
       CD.Activate
       Sheets("Suivi").Select
       Range("A15").Select
       ActiveSheet.Paste
    
     End If
    
    
    
     Application.DisplayAlerts = False

     Application.DisplayAlerts = True
  Next
 
 
     With Feuil130
     Range("A12").Select
     End With
      
      
   Application.DisplayAlerts = False
     CS.Close
     Application.DisplayAlerts = True
 

' Suppression une ligne sur 2 pour la Feuil de Suivi pour mise en cohérence des données brut
With Worksheets("Suivi")

Dim NpTotal As Double
Application.ScreenUpdating = False
NpTotal = Range("a65535").End(xlUp).Row
For i = 2 To NpTotal + 1
    Rows(i + 1).Delete
Next

End With


'Copie du suivi vers le rapport

Sheets("Suivi").Range("H9:H23").Copy
        With Sheets("Rapport")
            .Range("P28").PasteSpecial Paste:=xlPasteValues
        End With
    Application.CutCopyMode = False

Sheets("Suivi_K7").Range("H24:H38").Copy
        With Sheets("Rapport")
            .Range("P80").PasteSpecial Paste:=xlPasteValues
        End With
    Application.CutCopyMode = False

Sheets("Suivi").Range("H39:H53").Copy
        With Sheets("Rapport")
            .Range("P54").PasteSpecial Paste:=xlPasteValues
        End With
    Application.CutCopyMode = False
    
    
 Sheets("Suivi").Unprotect Password:="sandman"
    

Worksheets("Suivi").Range("A3:H8").ClearContents
Sheets("Suivi").Range("A3:H8").Select
    
 With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    
    
 Sheets("Suivi").Protect Password:="sandman"
    
    
 Application.ScreenUpdating = True
    
    
    Sheets("Rapport").Select
    Range("J18").Select

With Application
    .ScreenUpdating = True
    .EnableEvents = True
End With

    
End Sub

Code n° 2 : fusionne des cellules d'une feuil suivant une condition et applique une "formula" local dans une autre Feuil du classeur.


Code: 
Sub MiseenFormeStat()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Sheets("Archive (NE JAMAIS SUPP LE DOC)").Activate


With Sheets("Archive (NE JAMAIS SUPP LE DOC)")

For e = 8 To Range("A65500").End(xlUp).Row
    If Not IsEmpty(Range("A" & e)) And Range("A" & e) Like "*du*" Then
        Cells(e, 1).Resize(, 10).Merge
    Else
        Cells(e, "I") = SemJourNuit(e, 0)
        Cells(e, "J") = SemJourNuit(e, 1)
    End If
Next e

End With

Sheets("Statistiques").Activate

With Sheets("Statistiques")

[F36:F87].FormulaLocal = "=NB.SI.ENS('Archive (NE JAMAIS SUPP LE DOC)'!$I$9:$I$65000;$E36;'Archive (NE JAMAIS SUPP LE DOC)'!$J$9:$J$65000;$F$35)"

[G36:G87].FormulaLocal = "=NB.SI.ENS('Archive (NE JAMAIS SUPP LE DOC)'!$I$9:$I$65000;$E36;'Archive (NE JAMAIS SUPP LE DOC)'!$J$9:$J$65000;$G$35)"

End With

Sheets("SUIVIMANOEUVRE").Select

End Sub


Merci d'avance pour votre aide.

Désolé d'avance de ne pas transmettre de fichier. Données sensibles.

Bonne journée
 
Solution
Bernard_XLD
Avec la comparaison binaire, on gagne un peu de temps sur le test
VB: 
Sub Suivi()

Application.ScreenUpdating = False
'Dim CD As Workbook,
Dim OD As Worksheet, BSF As FileDialog
Dim fs As Byte, CS As Workbook, OS As Worksheet
Dim FN As Byte
Dim wb As Workbook
Dim lig&
Dim Etat_Calculation

With Application
    .ScreenUpdating = False
    .EnableEvents = False
    Etat_Calculation = Application.Calculation
    Application.Calculation = xlCalculationManual
End With
 
Sheets("Suivi").Unprotect Password:="sandman"

Worksheets("Suivi").Range("A15:S5000").ClearContents

'Set CD = ThisWorkbook ' cela ne sert à rien de référencer objet un objet existant
Set OD = ThisWorkbook.Worksheets(1)
Set BSF = Application.FileDialog(msoFileDialogOpen)...
Trier par date Trier par votes
Bonjour Spike29, le forum

vite fait en lecture rapide car je m'en vais, une première chose
ta boucle
VB: 
NpTotal = Range("a65535").End(xlUp).Row
For i = 2 To NpTotal + 1
    Rows(i + 1).Delete
Next
peut être remplacée par
Code: 
Rows("3:" & NpTotal + 2).Delete Shift:=xlUp

Bien cordialement, @+
 
Vote positif 0 Vote négatif
Bonjour Yeahou, Bonjour le Forum,

Merci pour ta réponse.

Ton code réduit considérablement le temps d’exécution de mon code passant d'environ 1min 45 à 15 sec.
Toutefois, la suppression d'une ligne sur deux comme le fait mon code initial ne se fait pas avec ton code.
Une idée ?

J'ai allégé mon code en conservant la même structure et je gagne en moyenne 30 sec d’exécution.

VB: 
NpTotal = Range("A85:A95").Row
For i = 2 To NpTotal + 1
    Rows(i + 1).Delete
Next

Mais ça ne reste pas très satisfaisant dans le sens ou je suis toujours à 1min10/15 de temps d’exécution.

Merci d'avance pour le coup de pouce.


Bonne fin de journée


Cordialement,
 
Vote positif 0 Vote négatif
voila déja pour ta suppression de ligne, ça ira plus vite
VB: 
Dim RangeSup As Range
NpTotal = Range("a65535").End(xlUp).Row
Set RangeSup = Range("A3")
For i = 5 To NpTotal + 2 Step 2
    Set RangeSup = Union(RangeSup, Range("A" & i))
Next
RangeSup.EntireRow.Delete Shift:=xlUp
 
Vote positif 0 Vote négatif
voila la première, à tester
Code: 
Sub Suivi()

Application.ScreenUpdating = False
'Dim CD As Workbook,
Dim OD As Worksheet, BSF As FileDialog
Dim fs As Byte, CS As Workbook, OS As Worksheet
Dim FN As Byte
Dim wb As Workbook
Dim lig&
Dim Etat_Calculation

With Application
    .ScreenUpdating = False
    .EnableEvents = False
    Etat_Calculation = Application.Calculation
    Application.Calculation = xlCalculationManual
End With
 
Sheets("Suivi").Unprotect Password:="sandman"

Worksheets("Suivi").Range("A15:S5000").ClearContents

'Set CD = ThisWorkbook ' cela ne sert à rien de référencer objet un objet existant
Set OD = ThisWorkbook.Worksheets(1)
Set BSF = Application.FileDialog(msoFileDialogOpen)
BSF.AllowMultiSelect = True
BSF.Show
If BSF.SelectedItems.Count = 0 Then Exit Sub
For fs = 1 To BSF.SelectedItems.Count
    Application.Workbooks.Open (BSF.SelectedItems(fs))
    Set CS = ActiveWorkbook
    Set OS = CS.Worksheets(1)
    If Left(CS.Name, 10) = "Export" Then
        OS.Range("B14:I104").Copy
        CD.Activate
        Sheets("Suivi").Select
        Range("A15").Select
        ActiveSheet.Paste
    End If
'    Application.DisplayAlerts = False ' cela ne sert à rien de désactiver pour réactiver derrière
'    Application.DisplayAlerts = True
Next fs
'With Feuil130'le end with ne sert à rien pour une seule instruction, en plus le range n'ayant pas de point, il ne s'y réfère pas
    Range("A12").Select
'End With
      
      
'   Application.DisplayAlerts = False 'pas la peine de désactiver les alarmes en précisant false à la fermeture
     CS.Close False
'     Application.DisplayAlerts = True
 

' Suppression une ligne sur 2 pour la Feuil de Suivi pour mise en cohérence des données brut
With Worksheets("Suivi")

    Dim NpTotal&, RangeSup As Range
    Application.ScreenUpdating = False
    NpTotal = Range("a65535").End(xlUp).Row
    Set RangeSup = Range("A3")
    For i = 5 To NpTotal + 2 Step 2
        Set RangeSup = Union(RangeSup, Range("A" & i))
    Next
    RangeSup.EntireRow.Delete Shift:=xlUp

'Copie du suivi vers le rapport

    Sheets("Rapport").Range("P28:P42").Value = .Range("H9:H23").Value
    Sheets("Rapport").Range("P80:P94").Value = Sheets("Suivi_K7").Range("H24:H38").Value
    Sheets("Rapport").Range("P54:P68").Value = .Range("H39:H53").Value
    
    .Unprotect Password:="sandman"
   
    With .Range("A3:H8")
        .ClearContents
        With .Interior
            .Pattern = xlNone
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
    End With
    
    .Protect Password:="sandman"
End With
    
Application.ScreenUpdating = True
    
Sheets("Rapport").Select
Range("J18").Select

With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = Etat_Calculation
End With

End Sub
 
Dernière édition:
Vote positif 0 Vote négatif
voila la deuxième
Bonne soirée, @+
Code: 
Sub MiseenFormeStat()
Dim Etat_Calculation
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Etat_Calculation = Application.Calculation
Application.Calculation = xlCalculationManual

Sheets("Archive (NE JAMAIS SUPP LE DOC)").Activate


With Sheets("Archive (NE JAMAIS SUPP LE DOC)")

For e = 8 To Range("A65500").End(xlUp).Row
    If Not IsEmpty(Range("A" & e)) And Range("A" & e) Like "*du*" Then
        Cells(e, 1).Resize(, 10).Merge
    Else
        Cells(e, "I") = SemJourNuit(e, 0)
        Cells(e, "J") = SemJourNuit(e, 1)
    End If
Next e

End With

Sheets("Statistiques").Activate

With Sheets("Statistiques")

[F36:F87].FormulaLocal = "=NB.SI.ENS('Archive (NE JAMAIS SUPP LE DOC)'!$I$9:$I$65000;$E36;'Archive (NE JAMAIS SUPP LE DOC)'!$J$9:$J$65000;$F$35)"

[G36:G87].FormulaLocal = "=NB.SI.ENS('Archive (NE JAMAIS SUPP LE DOC)'!$I$9:$I$65000;$E36;'Archive (NE JAMAIS SUPP LE DOC)'!$J$9:$J$65000;$G$35)"

End With

Sheets("SUIVIMANOEUVRE").Select
Application.Calculation = Etat_Calculation

End Sub
 
Vote positif 0 Vote négatif
Bonjour Yeahou, bonjour le fil,

Merci beaucoup pour ton aide. tes codes fonctionnent et me permettent de gagner du temps d’exécution, notamment pour le premier ou je passe en dessous la barre d'une minute de temps d’exécution.

Bonne journée et merci encore.
 
Vote positif 0 Vote négatif
Bonjour spike29, le forum

une minute, cela reste énorme, postes un fichier exemple light et anonymisé qu'on voit le type de données et de tableau et qu'on réduise cela.

Bien cordialement, @+
 
Dernière édition:
Vote positif 0 Vote négatif
sinon, sans autre information, essayes ce code
VB: 
Sub Suivi()

Application.ScreenUpdating = False
'Dim CD As Workbook,
Dim OD As Worksheet, BSF As FileDialog
Dim fs As Byte, CS As Workbook, OS As Worksheet
Dim FN As Byte
Dim wb As Workbook
Dim lig&
Dim Etat_Calculation

With Application
    .ScreenUpdating = False
    .EnableEvents = False
    Etat_Calculation = Application.Calculation
    Application.Calculation = xlCalculationManual
End With
 
Sheets("Suivi").Unprotect Password:="sandman"

Worksheets("Suivi").Range("A15:S5000").ClearContents

'Set CD = ThisWorkbook ' cela ne sert à rien de référencer objet un objet existant
Set OD = ThisWorkbook.Worksheets(1)
Set BSF = Application.FileDialog(msoFileDialogOpen)
BSF.AllowMultiSelect = True
BSF.Show
If BSF.SelectedItems.Count = 0 Then Exit Sub
For fs = 1 To BSF.SelectedItems.Count
    Application.Workbooks.Open (BSF.SelectedItems(fs))
    Set CS = ActiveWorkbook
    Set OS = CS.Worksheets(1)
    If Left(CS.Name, 10) = "Export" Then ThisWorkbook.Sheets("Suivi").Range("A15:H105").Value = OS.Range("B14:I104").Value
'    Application.DisplayAlerts = False ' cela ne sert à rien de désactiver pour réactiver derrière
'    Application.DisplayAlerts = True
Next fs
'With Feuil130'le end with ne sert à rien pour une seule instruction, en plus le range n'ayant pas de point, il ne s'y réfère pas
    Range("A12").Select
'End With
    
    
'   Application.DisplayAlerts = False 'pas la peine de désactiver les alarmes en précisant false à la fermeture
     CS.Close False
'     Application.DisplayAlerts = True
 

' Suppression une ligne sur 2 pour la Feuil de Suivi pour mise en cohérence des données brut
With Worksheets("Suivi")

    Dim RangeOri, RangeSup()
    Application.ScreenUpdating = False
    RangeOri = .Range("A3:H" & .Range("A65535").End(xlUp).Row + 2).Value
    ReDim RangeSup(LBound(RangeOri, 1) To UBound(RangeOri, 1), LBound(RangeOri, 2) To UBound(RangeOri, 2))
    For i = LBound(RangeOri, 1) To UBound(RangeOri, 1) Step 2
        If Not i / 2 = i \ 2 Then
            For z = LBound(RangeOri, 2) To UBound(RangeOri, 2)
                RangeSup((i + 1) / 2, z) = RangeOri(i, z)
            Next z
        End If
    Next i
    .Range("A3:H" & Range("a65535").End(xlUp).Row + 2).Value = RangeSup
    Set RangeOri = Nothing: Erase RangeSup

'Copie du suivi vers le rapport

    Sheets("Rapport").Range("P28:P42").Value = .Range("H9:H23").Value
    Sheets("Rapport").Range("P80:P94").Value = Sheets("Suivi_K7").Range("H24:H38").Value
    Sheets("Rapport").Range("P54:P68").Value = .Range("H39:H53").Value
  
    .Unprotect Password:="sandman"
 
    With .Range("A3:H8")
        .ClearContents
        With .Interior
            .Pattern = xlNone
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
    End With
  
    .Protect Password:="sandman"
End With
  
Application.ScreenUpdating = True
  
Sheets("Rapport").Select
Range("J18").Select

With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = Etat_Calculation
End With

End Sub
 
Dernière édition:
Vote positif 0 Vote négatif
Avec la comparaison binaire, on gagne un peu de temps sur le test
VB: 
Sub Suivi()

Application.ScreenUpdating = False
'Dim CD As Workbook,
Dim OD As Worksheet, BSF As FileDialog
Dim fs As Byte, CS As Workbook, OS As Worksheet
Dim FN As Byte
Dim wb As Workbook
Dim lig&
Dim Etat_Calculation

With Application
    .ScreenUpdating = False
    .EnableEvents = False
    Etat_Calculation = Application.Calculation
    Application.Calculation = xlCalculationManual
End With
 
Sheets("Suivi").Unprotect Password:="sandman"

Worksheets("Suivi").Range("A15:S5000").ClearContents

'Set CD = ThisWorkbook ' cela ne sert à rien de référencer objet un objet existant
Set OD = ThisWorkbook.Worksheets(1)
Set BSF = Application.FileDialog(msoFileDialogOpen)
BSF.AllowMultiSelect = True
BSF.Show
If BSF.SelectedItems.Count = 0 Then Exit Sub
For fs = 1 To BSF.SelectedItems.Count
    Application.Workbooks.Open (BSF.SelectedItems(fs))
    Set CS = ActiveWorkbook
    Set OS = CS.Worksheets(1)
    If Left(CS.Name, 10) = "Export" Then ThisWorkbook.Sheets("Suivi").Range("A15:H105").Value = OS.Range("B14:I104").Value
'    Application.DisplayAlerts = False ' cela ne sert à rien de désactiver pour réactiver derrière
'    Application.DisplayAlerts = True
Next fs
'With Feuil130'le end with ne sert à rien pour une seule instruction, en plus le range n'ayant pas de point, il ne s'y réfère pas
    Range("A12").Select
'End With
     
     
'   Application.DisplayAlerts = False 'pas la peine de désactiver les alarmes en précisant false à la fermeture
     CS.Close False
'     Application.DisplayAlerts = True
 

' Suppression une ligne sur 2 pour la Feuil de Suivi pour mise en cohérence des données brut
With ThisWorkbook.Worksheets("Suivi")

    Dim RangeTest As Range, RangeOri, RangeSup()
    Application.ScreenUpdating = False
    Set RangeTest = .Range("A3:H" & .Range("A65535").End(xlUp).Row + 2)
    RangeOri = RangeTest.Value
    ReDim RangeSup(LBound(RangeOri, 1) To UBound(RangeOri, 1), LBound(RangeOri, 2) To UBound(RangeOri, 2))
    For i = LBound(RangeOri, 1) To UBound(RangeOri, 1) Step 2
        If i And 1 Then ' comparaison binaire
            For z = LBound(RangeOri, 2) To UBound(RangeOri, 2)
                RangeSup((i + 1) / 2, z) = RangeOri(i, z)
            Next z
        End If
    Next i
    RangeTest.Value = RangeSup
    Set RangeTest = Nothing: Set RangeOri = Nothing: Erase RangeSup

'Copie du suivi vers le rapport

    Sheets("Rapport").Range("P28:P42").Value = .Range("H9:H23").Value
    Sheets("Rapport").Range("P80:P94").Value = Sheets("Suivi_K7").Range("H24:H38").Value
    Sheets("Rapport").Range("P54:P68").Value = .Range("H39:H53").Value
   
    .Unprotect Password:="sandman"
  
    With .Range("A3:H8")
        .ClearContents
        With .Interior
            .Pattern = xlNone
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
    End With
   
    .Protect Password:="sandman"
End With
   
Application.ScreenUpdating = True
   
Sheets("Rapport").Select
Range("J18").Select

With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = Etat_Calculation
End With

End Sub
 
Dernière édition:
Vote positif 0 Vote négatif
Solution
Bonsoir Yeahou, bonsoir le fil,

Un grand merci pour ta patience et ton aide très précieuse car ça a payé. J'ai testé ton dernier code et là le changement est radical.
Mon code met moins de 10 secondes à s’exécuter.
Merci encore 😀
 
Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

VBA_dev_Anne_Marie
  • Résolu(e)
Microsoft 365 VBA : copier 2 onglets
Réponses
4
Affichages
164
job75
job75
F
  • Question Question
Microsoft 365 aide VBA excel
Réponses
4
Affichages
669
Oneida
Oneida
M
  • Résolu(e)
Microsoft 365 Pouvez-vous traduire le code VBA SVP ?
Réponses
8
Affichages
310
MOLY_
M
F
  • Question Question
Microsoft 365 Problème mémoire insuffisante
Réponses
5
Affichages
696
TooFatBoy
TooFatBoy
J
  • Question Question
Microsoft 365 Copie des onglets dans un fichier séparé depuis une liste en VBA
Réponses
3
Affichages
390
job75
job75
thunder23
  • Résolu(e)
XL 2021 Bug dans code vba
Réponses
8
Affichages
643
thunder23
thunder23
T
  • Résolu(e)
Microsoft 365 VBA Exporter une sélection de plages nommées au format PDF
Réponses
12
Affichages
940
tnion
T
M
  • Question Question
XL 2019 La méthode select de la classe range a échoué
Réponses
4
Affichages
257
job75
job75
L
  • Question Question
Microsoft 365 Erreur automation 440 sur code VBA
Réponses
1
Affichages
300
job75
job75
T
  • Résolu(e)
XL 2019 Filtrer certains champs au démarrage avec vba
2
Réponses
15
Affichages
1 K
telemarrk
T
David Aubert
Optimisation de code VBA
Réponses
5
Affichages
206
Cléa
Cléa
klin89
  • Question Question
Microsoft 365 Méthode Evaluate pour se dispenser d'une boucle imbriquée
Réponses
14
Affichages
678
patricktoulon
patricktoulon
N
  • Question Question
XL 2016 Code VBA pour envoi de mail avec pdf en piece jointe
Réponses
4
Affichages
711
Phil69970
Phil69970
A
  • Question Question
VBA qui fonctionnait avant, mais ne fonctionne plus avec le 64 bits
Réponses
2
Affichages
585
patricktoulon
patricktoulon
M
  • Question Question
Microsoft 365 Macro VBA supprimer une colonne
Réponses
5
Affichages
573
marie3107
M
M
  • Question Question
Microsoft 365 Erreur sur mon Code VBA
Réponses
2
Affichages
665
Gégé-45550
Gégé-45550
P
  • Question Question
XL 2019 Changer nom d'export en VBA
Réponses
3
Affichages
796
job75
job75
Chaton77
  • Résolu(e)
Microsoft 365 Vba : Transférer des données d'un tableau dans un autre fichier
Réponses
7
Affichages
749
Chaton77
Chaton77
N
  • Question Question
Microsoft 365 Code VBA
Réponses
7
Affichages
907
TooFatBoy
TooFatBoy
lynyrd
  • Question Question
XL 2019 code pour tous les disques
Réponses
3
Affichages
833
AtTheOne
AtTheOne
Retour