vba - macro ralentissent le classeur

douguy

XLDnaute Junior
bonjour,

j'ai, pour les besoins d'un classeur, inséré des boutons de filtres fonctionnant par macro en togglebutton
N'étant pas doué j'ai récupéré et adapter des codes trouvés sur internet.
Ca marche mais ca mouline un peu trop a mon goût.

Est ce que quelqu'un aurait la gentillesse de regarder comment améliorer la rapidité de ces codes ?

Private Sub ToggleButton1_Click()
Range("15:21,29:42,50:56,57:84,92:119,127:154,162:168").EntireRow.Hidden = ToggleButton1
End Sub

Private Sub ToggleButton2_Click()
For Col = 3 To 500
If Cells(12, Col) <> "ACO" Then Columns(Col).Hidden = ToggleButton2
Next
End Sub

Private Sub ToggleButton3_Click()
Dim i As Integer
For i = Range("C1").Column To Range("nc1").Column
If Cells(10, i).Value > 34 Then Columns(i).Hidden = ToggleButton3
Next i
End Sub

Private Sub ToggleButton4_Click()
Dim dercolonne As Long
Dim i%
'numéro de la dernière colonne utilisée
dercolonne = Cells(10, 500).End(xlToLeft).Column
For i = 3 To dercolonne
If Cells(8, i) < Now() Then Columns(i).Hidden = ToggleButton4
Next i
End Sub
Private Sub ToggleButton5_Click()
Range("15:49,57:161").EntireRow.Hidden = ToggleButton5
End Sub

Private Sub ToggleButton6_Click()
Dim dercolonne As Long
Dim i%
'numéro de la dernière colonne utilisée
dercolonne = Cells(10, 500).End(xlToLeft).Column
For i = 3 To dercolonne
If Cells(23, i) < Cells(22, i) Then Columns(i).Hidden = ToggleButton6
Next i
End Sub
 

Staple1600

XLDnaute Barbatruc
Bonjour le fil, douguy

douguy
Si tu joignais un classeur exemple (préalablement anonymisé pour respecter le point 1 de la charte du forum), cela rendrait nos tentatives d'aide plus faciles (et faciliterait les tests de nos macros avant de les publier sur le forum).

Pour joindre un fichier, il suffit de cliquer sur : Joindre des fichiers
 

job75

XLDnaute Barbatruc
Bonjour douguy, JM,

Avec ces macros ce sera plus rapide :
VB:
Private Sub ToggleButton1_Click()
Range("15:21,29:42,50:56,57:84,92:119,127:154,162:168").EntireRow.Hidden = ToggleButton1
End Sub

Private Sub ToggleButton2_Click()
Application.ScreenUpdating = False
Rows(1).Insert
With Range(Cells(1, 3), Cells(1, 500))
    .FormulaR1C1 = "=1/(R13C<>""ACO"")"
    On Error Resume Next 'si aucune SpecialCell
    .SpecialCells(xlCellTypeFormulas, 1).EntireColumn.Hidden = ToggleButton2
End With
Rows(1).Delete
End Sub

Private Sub ToggleButton3_Click()
Application.ScreenUpdating = False
Rows(1).Insert
With Range(Cells(1, Range("C1").Column), Cells(1, Range("NC1").Column))
    .FormulaR1C1 = "=1/(R11C>34)"
    On Error Resume Next 'si aucune SpecialCell
    .SpecialCells(xlCellTypeFormulas, 1).EntireColumn.Hidden = ToggleButton3
End With
Rows(1).Delete
End Sub

Private Sub ToggleButton4_Click()
Application.ScreenUpdating = False
Rows(1).Insert
With Range(Cells(1, 3), Cells(1, Cells(11, 500).End(xlToLeft).Column))
    .FormulaR1C1 = "=1/(R9C<NOW())"
    On Error Resume Next 'si aucune SpecialCell
    .SpecialCells(xlCellTypeFormulas, 1).EntireColumn.Hidden = ToggleButton4
End With
Rows(1).Delete
End Sub

Private Sub ToggleButton5_Click()
Range("15:49,57:161").EntireRow.Hidden = ToggleButton5
End Sub

Private Sub ToggleButton6_Click()
Application.ScreenUpdating = False
Rows(1).Insert
With Range(Cells(1, 3), Cells(1, Cells(11, 500).End(xlToLeft).Column))
    .FormulaR1C1 = "=1/(R24C<R23C)"
    On Error Resume Next 'si aucune SpecialCell
    .SpecialCells(xlCellTypeFormulas, 1).EntireColumn.Hidden = ToggleButton6
End With
Rows(1).Delete
End Sub
A+
 
Dernière édition:

job75

XLDnaute Barbatruc
On peut alléger le code avec la macro paramétrée Masque (mais ce n'est pas plus rapide) :
VB:
Private Sub ToggleButton1_Click()
Range("15:21,29:42,50:56,57:84,92:119,127:154,162:168").EntireRow.Hidden = ToggleButton1
End Sub

Private Sub ToggleButton2_Click()
Masque 3, 500, "=1/(R13C<>""ACO"")", ToggleButton2
End Sub

Private Sub ToggleButton3_Click()
Masque Range("C1").Column, Range("NC1").Column, "=1/(R11C>34)", ToggleButton3
End Sub

Private Sub ToggleButton4_Click()
Masque 3, 500, "=1/(R9C<NOW())", ToggleButton4
End Sub

Private Sub ToggleButton5_Click()
Range("15:49,57:161").EntireRow.Hidden = ToggleButton5
End Sub

Private Sub ToggleButton6_Click()
Masque 3, Cells(10, 500).End(xlToLeft).Column, "=1/(R24C<R23C)", ToggleButton6
End Sub

Sub Masque(col1%, col2%, formule$, bouton As ToggleButton)
Application.ScreenUpdating = False
Rows(1).Insert
With Range(Cells(1, col1), Cells(1, col2))
    .FormulaR1C1 = formule
    On Error Resume Next 'si aucune SpecialCell
    .SpecialCells(xlCellTypeFormulas, 1).EntireColumn.Hidden = bouton
End With
Rows(1).Delete
End Sub
 

douguy

XLDnaute Junior
bonjour Staple et Job75
Merci bcp pour vos réponses
@staple, oui c'est vrai, je me disais que comme les macros étaient assez simples ca pouvait passer comme ça.
@job, je test tout ca et reviens te dire.

Merci bcp en tout cas, c'est sympa comme tout
 

Discussions similaires

Statistiques des forums

Discussions
311 711
Messages
2 081 786
Membres
101 817
dernier inscrit
carvajal