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..
A+