Alléger codes

R

ripo

XLDnaute Junior
Bonjour à toutes et à tous,

Il y a quelques temps, j'ai créé un fichier avec macros, mais à force de le faire évoluer, il devient lent!
Je ne sais pas comment m'y prendre pour alléger ces codes.
Merci pour votre aide
Ripo

ci joint les codes... navré, je ne peux pas réduire le fichier à 48ko
_________________________________________________________________________
Private Sub CommandButton1_Click()
Selection.AutoFilter Field:=1
Selection.AutoFilter Field:=2
Selection.AutoFilter Field:=3
Selection.AutoFilter Field:=4
Selection.AutoFilter Field:=5
Selection.AutoFilter Field:=6
Range("B1").Select
RechercheFiltre
ActiveWindow.SmallScroll Down:=-2000
End Sub

Private Sub CommandButton2_Click()
With Sheets("chrono stock")
Selection.AutoFilter Field:=1
Selection.AutoFilter Field:=2
Selection.AutoFilter Field:=3
Selection.AutoFilter Field:=4
Selection.AutoFilter Field:=5
Selection.AutoFilter Field:=6
.Range("B1").Select
.Rows("3:10000").EntireRow.Hidden = False
ActiveWindow.SmallScroll Down:=-2000
End With
End Sub

Private Sub CommandButton3_Click()
Selection.AutoFilter Field:=1
Selection.AutoFilter Field:=2
Selection.AutoFilter Field:=3
Selection.AutoFilter Field:=4
Selection.AutoFilter Field:=5
Selection.AutoFilter Field:=6
Range("A1").Select
RechercheFiltre2
ActiveWindow.SmallScroll Down:=-2000
End Sub

Private Sub CommandButton4_Click()
Selection.AutoFilter Field:=1
Selection.AutoFilter Field:=2
Selection.AutoFilter Field:=3
Selection.AutoFilter Field:=4
Selection.AutoFilter Field:=5
Selection.AutoFilter Field:=6
Selection.AutoFilter Field:=2, Criteria1:="=-----*", Operator:=xlAnd
End Sub
_________________________________________________________________________
Option Explicit
Sub RechercheFiltre2()
Dim Lig As Integer, Plage As Range, Cell As Range, Zone As Range
Dim Msg As String, Style, Title As String, MyValue As Variant
Dim Cible As String, Val As Range

Application.ScreenUpdating = False
With Sheets("chrono stock")
.Rows("3:10000").EntireRow.Hidden = False
' Plage à vérifier
Lig = .Range("A10000").End(xlUp).Row
Set Plage = .Range("A3:A" & Lig)
'Mot à chercher
Cible = InputBox(" Saisir la référence LM à rechercher : ", "FILTRE AUTOMATIQUE", "Ref. LM?")
If Cible = "" Or Cible = "Ref. LM?" Then Exit Sub
'Recherche dans la colonne A
For Each Cell In Plage
Cell.Select
Set Val = Cell.Find(What:=Cible, After:=ActiveCell, LookIn:=xlValues, LookAt:=xlPart)
If Not Val Is Nothing Then
Cell.EntireRow.Hidden = False
Else
Cell.EntireRow.Hidden = True ' Masquer les lignes du tableau
End If
Next
Range("A1").Select
End With
End Sub
___________________________________________________________________________
Option Explicit
Sub RechercheFiltre()
Dim Lig As Integer, Plage As Range, Cell As Range, Zone As Range
Dim Msg As String, Style, Title As String, MyValue As Variant
Dim Cible As String, Val As Range

Application.ScreenUpdating = False
With Sheets("chrono stock")
.Rows("3:10000").EntireRow.Hidden = False
' Plage à vérifier
Lig = .Range("B10000").End(xlUp).Row
Set Plage = .Range("B3:B" & Lig)
'Mot à chercher
Cible = InputBox(" Saisir toute ou partie de la désignation à rechercher : ", "FILTRE AUTOMATIQUE", "désignation?")
If Cible = "" Or Cible = "désignation?" Then Exit Sub
'Recherche dans la colonne B
For Each Cell In Plage
Cell.Select
Set Val = Cell.Find(What:=Cible, After:=ActiveCell, LookIn:=xlValues, LookAt:=xlPart)
If Not Val Is Nothing Then
Cell.EntireRow.Hidden = False
Else
Cell.EntireRow.Hidden = True ' Masquer les lignes du tableau
End If
Next
Range("B1").Select
End With
End Sub
_______________________________________________________________________
Sub Macro1()
'
' Macro1 Macro
' Macro enregistrée le 14/06/2008 par ripo'

'
Selection.AutoFilter Field:=1
Selection.AutoFilter Field:=2
Selection.AutoFilter Field:=3
Selection.AutoFilter Field:=4
Selection.AutoFilter Field:=5
Selection.AutoFilter Field:=6
End Sub
___________________________________________________________________________
Option Explicit
Dim vNow As Variant
 
Trier par date Trier par votes
K

kjin

XLDnaute Barbatruc
Re : Alléger codes

Bonsoir, bonsoir tototiti,
J'y comprends pas plus néanmoins
ripo à dit:
'....
' Plage à vérifier
Lig = .Range("B10000").End(xlUp).Row
Set Plage = .Range("B3:B" & Lig)
'Mot à chercher
Cible = InputBox(" Saisir toute ou partie de la désignation à rechercher : ", "FILTRE AUTOMATIQUE", "désignation?")
If Cible = "" Or Cible = "désignation?" Then Exit Sub
'Recherche dans la colonne B
For Each Cell In Plage
Cell.Select
Set Val = Cell.Find(What:=Cible, After:=ActiveCell, LookIn:=xlValues, LookAt:=xlPart)
If Not Val Is Nothing Then
Cell.EntireRow.Hidden = False
'....
Cliquez pour agrandir...
Puisque tu recherches les cellules contenant la valeur "Cible" pourquoi ne pas simplement écrire
Code: 
'....
' Plage à vérifier
Lig = .Range("B10000").End(xlUp).Row
Set Plage = .Range("B3:B" & Lig)
'Mot à chercher
Cible = InputBox(" Saisir toute ou partie de la désignation à rechercher : ", "FILTRE AUTOMATIQUE", "désignation?")
If Cible = "" Or Cible = "désignation?" Then Exit Sub
'Recherche dans la colonne B
For Each Cell In Plage
If Cell = Cible Then Cell.EntireRow.Hidden = False
'....
A+
kjin
 
Vote positif 0 Vote négatif
tototiti2008

tototiti2008

XLDnaute Barbatruc
Re : Alléger codes

Bonsoir kjin,

et puis

Code: 
Selection.AutoFilter Field:=1
Selection.AutoFilter Field:=2
Selection.AutoFilter Field:=3
Selection.AutoFilter Field:=4
Selection.AutoFilter Field:=5
Selection.AutoFilter Field:=6

ne peut-il être remplacé par

Code: 
ActiveSheet.ShowAllData

ou quelque chose du genre ?
 
Vote positif 0 Vote négatif
K

kjin

XLDnaute Barbatruc
Re : Alléger codes

Re, bonsoir luki,
A y être
Code: 
Sub RechercheFiltre2()
Dim Lig As Integer, Plage As Range, Cell As Range, Zone As Range
Dim Msg As String, Style, Title As String, MyValue As Variant
Dim Cible As String, Val As Range

Application.ScreenUpdating = False
With Sheets("chrono stock")
.Rows("3:10000").EntireRow.Hidden = False
' Plage à vérifier
Lig = .Range("A10000").End(xlUp).Row
Set Plage = .Range("A3:A" & Lig)
'Mot à chercher
Cible = InputBox(" Saisir la référence LM à rechercher : ", "FILTRE AUTOMATIQUE", "Ref. LM?")
If Cible = "" Or Cible = "Ref. LM?" Then Exit Sub
'Recherche dans la colonne A
Plage.AutoFilter Field:=1, Criteria1:=Cible
End With
End Sub
A+
kjin
 
Dernière édition:
Vote positif 0 Vote négatif
R

ripo

XLDnaute Junior
Re : Alléger codes

tototiti2008,Luki,Kjin,le forum... merci.
Ci joint fichier allégé avec explications
Merci de votre contribution
A+
Ripo
 

Pièces jointes

  • ripo.xls
    46 KB · Affichages: 98
  • ripo.xls
    46 KB · Affichages: 113
  • ripo.xls
    46 KB · Affichages: 110
Vote positif 0 Vote négatif
K

kjin

XLDnaute Barbatruc
Re : Alléger codes

Bonjour,
Un essai avec ce que j'ai compris et testé sur 12000 lignes
La recherche par désignation se fait sur un mot (GEO par exemple)
Pour ma part, en ce qui concerne les références, les formats exotiques sont proscrits
A+
kjin
 

Pièces jointes

  • ripo_v1.zip
    38.7 KB · Affichages: 28
Vote positif 0 Vote négatif

Discussions similaires

Usine à gaz
  • Résolu(e)
XL 2021 Filtrage que je ne parviens pas à faire
Réponses
6
Affichages
391
Usine à gaz
Usine à gaz
G
  • Question
Microsoft 365 Incompatibilité de type - Array
Réponses
2
Affichages
246
guiyom
G
S
  • Résolu(e)
XL 2016 Besoin d'aide pour un code d'extraction
Réponses
14
Affichages
330
Phil69970
Phil69970
C
  • Question
XL 2021 Dernière ligne d'un fichier fermé
Réponses
7
Affichages
215
Chris 33
C
M
  • Question
Microsoft 365 Question code VBA
Réponses
2
Affichages
135
Maxou69
M
F
  • Question
Microsoft 365 Poursuivre ou pas la macro
Réponses
2
Affichages
225
Francky79
F
M
  • Question
Microsoft 365 Création fichier texte
2
Réponses
15
Affichages
230
patricktoulon
patricktoulon
P
  • Résolu(e)
XL 2016 4 étapes en 1 seule Excel vba
Réponses
4
Affichages
488
Pygos691
P
chaelie2015
  • Question
XL 2013 Réduire un code
Réponses
0
Affichages
261
chaelie2015
chaelie2015
B
  • Résolu(e)
Microsoft 365 Besoin d'aide pour faire fonctionner 2 codes VBA ensemble
Réponses
2
Affichages
166
BenExcel
B

Membres actuellement en ligne

14 membres et 108 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
312 396
Messages
2 088 044
Membres
103 707
dernier inscrit
Papy60