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

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
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)...

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,
 
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:
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
 

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.
 
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:
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:

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
 

Discussions similaires

Statistiques des forums

Discussions
311 715
Messages
2 081 822
Membres
101 821
dernier inscrit
hybroxis