XL 2013 probleme filtres avec macro vba

[fab322]

Bonjour à tous;

Urgent besoin d'aide.
Je suis également débutante en vba, cela dit j'essaye de m'améliorer

voici ci joint mon fichier, il s'agit de gestion de maintenance préventive. Ma macro maintenance fonctionne relativement bien si le fichier n'est pas trop lourd (peu de lignes). Par contre cela rame avec un nombre important de lignes (3000 environ).
Je souhaite donc utiliser des filtres sur ma feuille PMP_2016, puis lancer ma macro en fonction des filtres ajoutés (par exemple code atelier BREBIOU et année 2016 dans date de la prochaine intervention).
En résumé je souhaite que ma macro se lance que pour les lignes sélectionnées via les filtres.

Merci à vous

fab

 

[Lone-wolf]

Re : probleme filtres avec macro vba

Bonsoir fab et bienvenue sur XLD

Pour les filtres; avec ceci tu peux choisir n'importe qu'elle colonne.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.ScreenUpdating = False
Range("a1:p65000").AutoFilter Field:=ActiveCell.Column, Criteria1:=ActiveCell.Value, Operator:=xlAnd

With Cells.SpecialCells(xlCellTypeVisible)
Call Maintenance
End with
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Application.ScreenUpdating
Range("a1:p65000").AutoFilter
End Sub

 

[fab322]

Re : probleme filtres avec macro vba

Bonsoir fab et bienvenue sur XLD

Pour les filtres; avec ceci tu peux choisir n'importe qu'elle colonne.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.ScreenUpdating = False
Range("a1:p65000").AutoFilter Field:=ActiveCell.Column, Criteria1:=ActiveCell.Value, Operator:=xlAnd

With Cells.SpecialCells(xlCellTypeVisible)
Call Maintenance
End with
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Application.ScreenUpdating
Range("a1:p65000").AutoFilter
End Sub

Merci beaucoup pour votre réactivité

J'ai testé en mettant ce private sub sur mon thisworkbook et j'obtiens une erreur au niveau de l'application.ScreenUpdating ,
voir ci joint image

 

[Lone-wolf]

Re : probleme filtres avec macro vba

Re fab

Si j'ai mis la macro dans Worksheet pourquoi tu va la mettre dans ThisWorkbook?? C'est en selectionnant une cellule de la feuille que tu vas filtrer les données et non pour toutes les feuilles.

 

[fab322]

Re : probleme filtres avec macro vba

ceci dit j'ai essayé avec application.sreen updating=true
cela n'affiche plus d'erreur, mais cela rame toujours autant, je pense que le problème vient de la boucle "do" dans sub maintenance.
en effet , cette boucle lit de la ligne 9 à ligne 2621 au lieu de lire seulement les cellules filtrées.

 

[Lone-wolf]

Re : probleme filtres avec macro vba

Bonsoir fab

J'ai modifié comme ceci dans la Sub Maintenance, mais bon, je ne sais pas si c'est celà que tu veux.

If Reponse = vbYes Then
Feuil9.Activate
With ActiveSheet
.Range("a8:q140").AutoFilter Field:=ActiveCell.Column, Criteria1:=ActiveCell, Operator:=xlAnd
End With
Else
sortie_macro = 0
End If

 

[fab322]

Re : probleme filtres avec macro vba

Bonjour et merci Lone-wolf;

en effet j'ai essayé mais sur mon fichier de 2621 lignes ça ramee, cela vient de la boucle "do"

Do

i = i + 1

Loop Until Cells(i, 2) = ""
ReDim tabrep(i)
nbreligne = i - lignetitre - 1 'nombre de ligne d'opération de maintenance
premiereligne = lignetitre + 1 'numéro de la premiere ligne de maintenance

'fin comptage du nombre de ligne occupées

'tests sur les fréquences

For N = premiereligne To i - 1

cette boucle lit de la ligne 9 (lignetitre+1) à la dernière ligne de mon tableau (ici 2621), puis pour chaque ligne lue, la macro s'effectue, même si j'applique des filtres.

Je pense que c'est dans la boucle "do" qu'il faut apporter une modification, du type :
faire la macro pour i=première ligne filtrée à la dernière ligne filtrée du tableau

Merci pour ton aide

 

[Lone-wolf]

Re : probleme filtres avec macro vba

Bonjour fab

pour i=première ligne filtrée à la dernière ligne filtrée du tableau

D'après ce que tu viens de dire, il suffit dans ce cas de supprimer la boucle.

 

[fab322]

Re : probleme filtres avec macro vba

J'ai trouvé une boucle qui reprend bien les cellules filtrées, mais j'ai du faire une erreur dans mon programme, car si je clique oui sur le message box, il devrait m'ouvrir mon useform description, or là ça boucle sur le premier message box.

voici le programme, en vert les zones ajoutées ou modifiées.

Sub Maintenance() 'chaque clique ou chaque changement de cellule
nom_feuille = ActiveWorkbook.ActiveSheet.Name 'recuperation du nom de la feuille

If ActiveCell.Column = 8 Or ActiveCell.Column = 7 Or ActiveCell.Column = 16 Or ActiveCell.Column = 9 Or ActiveCell.Column = 19 Then Exit Sub 'la macro n'est pas réalisée lorsque l'on clique dans les colonne G et H
If sortie_macro = 1 Then Exit Sub

'initialisation des variables
t = 0
aujourdhui = Date
lignetitre = 8
lastmaint = "P"
nextmaint = "Q"
typefreq = "O"
freq = "N"
i = lignetitre
freq1 = "jour"
freq2 = "mois"
freq3 = "an"
freq4 = "cycle"

message_alerte = 0
pre_alerte = -7 'message alerte s'affiche tant de jour(s) avant la date de la prochaine maintenance

'initialisation du message d'erreur

Msg = "Au moins une des opérations doit être envisagée dans les " & Abs(pre_alerte) & " prochains jours. Voulez-vous accedez à la premiere intervention ?" ' Définit le message.
Style = vbYesNo + vbCritical + vbDefaultButton2 'Définit les boutons.
Title = "Message d'ALERTE " 'Définit le titre.


'Fin initialisation des variables

'comptage du nombre de ligne occupées
Application.ScreenUpdating = False
Range("A9", Range("A3000").End(xlUp)).Select

'on place dans un tableau les N° de lignes visibles

For Each cellule In Selection.SpecialCells(xlCellTypeVisible)
On Error Resume Next
Tablo.Add cellule.Row, CStr(cellule.Row)
Next

'on reprend les N° de lignes depuis la fin du tableau

For N = Tablo.Count To 9 Step -1 'boucle sur toutes les lignes filtrées

celltypefreq = typefreq & N 'cellule à lire
If Range(celltypefreq) = freq1 Then decalage = "d" 'determination du type de décalage determiné par le type de fréquence
If Range(celltypefreq) = freq2 Then decalage = "m" 'determination du type de décalage determiné par le type de fréquence
If Range(celltypefreq) = freq3 Then decalage = "yyyy" 'determination du type de décalage determiné par le type de fréquence
If Range(celltypefreq) = freq4 Then 'écrit "suivant fréquence" dans cellule "date prochaine maintenance"
celldatnextmaint = nextmaint & N: Range(celldatnextmaint).Value = "suivant frequence": GoTo ligne1
End If 'à modifier suivant le type de fréquence
'calcul de la prochaine date de maintenance
cellfreq = freq & N 'cellule à lire
datelastmaint = DateValue(Cells(N, lastmaint).Value) 'mise en forme de la date de la derniere maintenance
nbrefreq = Range(cellfreq).Value 'récuperation de la fréquence
journextmaint = DateAdd(decalage, nbrefreq, datelastmaint) 'calcul du jour de la prochaine maintenance

celldatnextmaint = nextmaint & N 'cellule de destination
Range(celldatnextmaint).Value = journextmaint 'écriture dans la cellule de destination

date_alerte = DateAdd("d", pre_alerte, journextmaint)
If aujourdhui >= date_alerte Then message_alerte = 1: Tablo(t) = N: t = t + 1 'test pour message d'alerte, on met message_alerte à 1 si au
'moins une date dépassée, on met le numéro de ligne dans le tableau
'tabrep à la position t
ligne1:
Application.ScreenUpdating = True
Next

If message_alerte = 1 Then Reponse = MsgBox(Msg, Style, Title) 'affichage du message

postabrep = 0 'initilaisation de la position dans le tableau Tablo()
premierelignemauvaise = lastmaint & Tablo(postabrep) 'position de la premiere cellule rouge
If Reponse = vbYes Then sortie_macro = 1: affichage_messages
sortie_macro = 0
End Sub

 

[Lone-wolf]

Re : probleme filtres avec macro vba

Bonjour

Si tu ne met pas description.Show après If Reponse = vbYes Then, comment veux-tu l'afficher?