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

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
S

spike29

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

Bernard_XLD

XLDnaute Barbatruc
Membre du Staff
Supporter XLD
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
Bernard_XLD

Bernard_XLD

XLDnaute Barbatruc
Membre du Staff
Supporter XLD
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
S

spike29

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

Bernard_XLD

XLDnaute Barbatruc
Membre du Staff
Supporter XLD
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
Bernard_XLD

Bernard_XLD

XLDnaute Barbatruc
Membre du Staff
Supporter 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)
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
S

spike29

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

Discussions similaires

F
  • Question
Microsoft 365 aide VBA excel
Réponses
4
Affichages
302
Oneida
Oneida
A
  • Question
VBA qui fonctionnait avant, mais ne fonctionne plus avec le 64 bits
Réponses
2
Affichages
136
patricktoulon
patricktoulon
N
  • Question
XL 2016 Code VBA pour envoi de mail avec pdf en piece jointe
Réponses
4
Affichages
307
Phil69970
Phil69970
riton00
  • Résolu(e)
XL 2021 Modification d'un code VBA
Réponses
5
Affichages
348
kiki29
kiki29
M
  • Question
Microsoft 365 Macro VBA supprimer une colonne
Réponses
5
Affichages
350
marie3107
M
M
  • Question
Microsoft 365 Erreur sur mon Code VBA
Réponses
2
Affichages
349
Gégé-45550
Gégé-45550
Chaton77
  • Résolu(e)
Microsoft 365 Vba : Transférer des données d'un tableau dans un autre fichier
Réponses
7
Affichages
404
Chaton77
Chaton77
P
  • Question
XL 2019 Changer nom d'export en VBA
Réponses
3
Affichages
483
job75
job75
N
  • Question
Microsoft 365 Recherche dans un tableau structuré à partir d'une TextBox
Réponses
11
Affichages
300
NONO14
N
M
  • Question
Microsoft 365 Copier / coller avec mise en forme VBA
Réponses
0
Affichages
540
marie3107
M

Membres actuellement en ligne

13 membres et 75 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
315 090
Messages
2 116 107
Membres
112 661
dernier inscrit
ceucri