Optimisation de mon code VBA (lenteur à l'exécution)

Bonjour,

J'ai un code VBA qui s'exécute à chaque fois que l'on va sur une page mais malheureusement il y a facilement un temps de 2 à 3 secondes pour que la page finisse de se charger. Est-ce qu'il y aurait un moyen d'optimiser le temps d'exécution de ma macro ?

Private Sub Workbook_SheetActivate(ByVal sh As Object)
Application.ScreenUpdating = False
On Error Resume Next
Dim i As Integer
    Columns("A:A").ClearContents
    Range("A1").Select
    For i = 1 To Sheets.Count
        If Worksheets(i).Name <> "Template" And Worksheets(i).Name <> "Template (2)" Then
           ActiveCell.Value = Sheets(i).Name
           ActiveCell.Offset(1, 0).Select
        End If
    Next i
    With Range("B9:C9").Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:="=OFFSET($A$1,0,0,COUNTA($A:$A))"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = "Erreur"
        .InputMessage = ""
        .ErrorMessage = "Merci de sélectionner une qualité présente dans la liste déroulante !"
        .ShowInput = True
        .ShowError = True
    End With
Sheets("Template").Range("D3:L3").Copy
ActiveSheet.Range("D3:L3").Select
Selection.PasteSpecial Paste:=xlPasteValidation, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Application.GoTo Range("A6"), True
End Sub

Salutations,
Cédric Pillonel.

Bonjour,

Un essai ...

Pas sûr que l'accélération te décoiffera ...

Private Sub Workbook_SheetActivate(ByVal sh As Object)
   Application.ScreenUpdating = False
   On Error Resume Next
   Dim i As Integer, J As Integer

   Columns("A:A").ClearContents
   J = 1

   For i = 1 To Sheets.Count
      If Worksheets(i).Name <> "Template" And Worksheets(i).Name <> "Template (2)" Then
         Cells("A" & J).Value = Sheets(i).Name
         J = J + 1
      End If
   Next i

   With Range("B9:C9").Validation
      .Delete
      .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
           xlBetween, Formula1:="=OFFSET($A$1,0,0,COUNTA($A:$A))"
      .IgnoreBlank = True
      .InCellDropdown = True
      .InputTitle = ""
      .ErrorTitle = "Erreur"
      .InputMessage = ""
      .ErrorMessage = "Merci de sélectionner une qualité présente dans la liste déroulante !"
      .ShowInput = True
      .ShowError = True
   End With
   Sheets("Template").Range("D3:L3").Copy
   ActiveSheet.Range("D3:L3").PasteSpecial Paste:=xlPasteValidation, Operation:=xlNone, _
                          SkipBlanks:=False, Transpose:=False
   Application.CutCopyMode = False
   Application.GoTo Range("A6"), True
End Sub

ric

Bonjour à tous,

Je mettrais ça au début, tout inscrire en une fois pour gagner un peu.
Mais bon, pareil, à moins d'avoir 300 feuilles ça ne va pas te faire gagner grand chose :

    Dim feuille() As String
    Application.ScreenUpdating = False
    ' On Error Resume Next ' non!!!
    Dim i As Integer
    Columns("A:A").ClearContents
    ReDim feuille(1 To Sheets.Count, 1 To 1)
    For i = 1 To Sheets.Count
        If Worksheets(i).Name <> "Template" And Worksheets(i).Name <> "Template (2)" Then
            feuille(i, 1) = Sheets(i).Name
        End If
    Next i
    [A1].Resize(Sheets.Count) = feuille

A tout hasard ajouter au début :
Application.Calculation = xlCalculationManual
remettre à xlCalculationAutomatic à la fin.
Sans grande conviction non plus...

Pourquoi remettre tes validations ? Elles peuvent avoir été abimées ?
eric

Merci à vous deux, je regarde si ça avance un peu plus vite ou non .

@eriiic Parce que j'ai une macro qui me duplique une page "template" et sur cette page template je ne veux pas qu'on puisse modifier le titre de la page en D3:L3 alors j'ai mis en validation de données "personnalisé" puis dans le champ j'ai mis des guimets comme ça les gens peuvent pas modifier la cellule et quand la page se duplique je souhaites avoir d'autres validations de données qui sont celles ci-dessous .

Avec vos modifications c'est déjà bien plus rapide entre les pages maintenant !
Merci beaucoup !!

Par contre j'ai découvert un autre code qui me faisait planté mon excel dès que j'avais pas mal de page et qui ralenti énormément.
C'est celui-ci pour le tri des feuilles automatiques par ordre alphabétique :

Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
Dim a As Integer, b As Integer
sh = Target.Parent.Name
For a = 1 To Sheets.Count
    For b = a + 1 To Sheets.Count
        If UCase(Sheets(a).Name) > UCase(Sheets(b).Name) Then
            Sheets(b).Move before:=Sheets(a)
        End If
    Next b
Next a
Sheets(sh).Activate
End Sub

Auriez-vous quelque chose de mieux à me proposer ?

à voir :

Sub triFeuil()
    Dim NomF, arrNomF As Object, i As Long
    Set arrNomF = CreateObject("System.Collections.ArrayList")
    For i = 1 To Sheets.Count
        arrNomF.Add Sheets(i).Name
    Next i
    arrNomF.Sort
    For Each NomF In arrNomF
        Sheets(NomF).Move after:=Sheets(Sheets.Count)
    Next NomF
End Sub

le tri est fait par la méthode .Sort très optimisée, de plus chaque feuille n'est déplacée qu'une fois au maximum (plus de double boucle)
eric

Merci !
Est-ce possible à la fin de chaque lancement de la macro de revenir à la page d'avant de commencer le tri ?

Bonjour,

Sub triFeuil()
    Dim NomF, arrNomF As Object, i As Long, sh As Worksheet
    Set arrNomF = CreateObject("System.Collections.ArrayList")
    Set sh = ActiveSheet
    Application.ScreenUpdating = False
    For i = 1 To Sheets.Count
        arrNomF.Add Sheets(i).Name
    Next i
    arrNomF.Sort
    For Each NomF In arrNomF
        Sheets(NomF).Move after:=Sheets(Sheets.Count)
    Next NomF
    sh.Select
End Sub

Quel tri ?
Tu inséres l'appel triFeuil là où tu dois le faire et la suite continuera après.
eric

Salut Cédric,
Salut les as,

2-3 secondes à charger ? Combien de feuilles y a-t-il, donc ?
Je te propose ceci qui a l'avantage d'une gestion "complète" (n'exagérons rien non plus...) de ta demande.
- tu devras choisir UNE feuille-référence, hors "Template" et "Template (2)" pour recevoir la liste "officielle" de tes noms de feuille.
Dans l'exemple fourni, la feuille "A", et pour être cohérent dans ton fichier, la première feuille après les "Template" serait logique ;
- à chaque changement de feuille, cette liste s'affiche simplement sans temps d'attente ;
- son nom s'affiche en GRAS dans la feuille-référence. Pourquoi ? Je n'en sais rien : à toi, en fonction de ton travail, à y trouver une utilité ;
- tu peux créer une nouvelle feuille : une InputBox te demandera son nom avant de l'envoyer dans la liste en 'A' qui sera triée, entraînant le tri des onglets

Private Sub Workbook_NewSheet(ByVal Sh As Object)
'
Dim sSheet$
'
Do
    sSheet = Application.InputBox("Quel nom donnez-vous à cette nouvelle feuille ?", "PILLONEL-Info", , , , , , 2)
Loop Until sSheet <> "" And sSheet <> "Faux" And sSheet <> "A"
Sh.Name = sSheet
With Worksheets("A")
    iRow = .Range("A" & Rows.Count).End(xlUp).Row + 1
    .Range("A" & iRow).Value = sSheet
    .Range("A1:A" & iRow).Sort key1:=.[A1], order1:=xlAscending, Orientation:=xlByRows, Header:=xlNo
    For x = 1 To .Range("A" & Rows.Count).End(xlUp).Row
        Worksheets(.Range("A" & x).Value).Move after:=Sheets(Sheets.Count)
    Next
End With
Sh.Activate
'
End Sub

- à chaque activation d'une feuille, la macro compare le nombre de feuilles avec le nombre d'items dans la liste de 'A' : si elle détecte une différence, la liste s'actualise.
Ainsi, la suppression d'une feuille est gérée indirectement.

With Worksheets("A")
    iRow = .Range("A" & Rows.Count).End(xlUp).Row
    If Sheets.Count <> iRow + 2 Then
        .Columns(1).Font.Bold = False
        Range("A1:A" & iRow).Value = ""
        For x = 1 To Sheets.Count
            If Sheets(x).Name <> "Template" And Sheets(x).Name <> "Template (2)" Then _
                .Range("A" & .Range("A" & Rows.Count).End(xlUp).Row + IIf(.[A1] = "", 0, 1)).Value = Sheets(x).Name
        Next
        .Activate
    End If
End With

- dans 'A', un clic DROIT sur un nom de la liste te permet de renommer cette feuille avec nouveaux tris de la liste et des onglets

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
'
Dim sItem$, sSheet$
'
If Target.Column = 1 And Target <> "" And Target <> "A" Then
    Cancel = True
    sItem = Target
    sSheet = Application.InputBox("Quel nouveau nom donnez-vous à la feuille '" & sItem & "' ?", "PILLONEL-Info", , , , , , 2)
    If sSheet <> "" And sSheet <> "Faux" And sSheet <> "A" Then
        With Worksheets("A")
            Target = sSheet
            Worksheets(sItem).Name = sSheet
            iRow = .Range("A" & Rows.Count).End(xlUp).Row
            .Range("A1:A" & iRow).Sort key1:=.[A1], order1:=xlAscending, Orientation:=xlByRows, Header:=xlNo
            For x = 1 To iRow
                Worksheets(.Range("A" & x).Value).Move after:=Sheets(Sheets.Count)
            Next
        End With
    End If
End If
'
End Sub

Simplicité, rapidité... à tester..

9pillonel.xlsm (24.16 Ko)


A+

Rechercher des sujets similaires à "optimisation mon code vba lenteur execution"