Macro filtre bug car aucun critère

J

John38

XLDnaute Nouveau
Bonjour,

Je suis novice en macro. Habituellement j'utilise que l'enregistreur de macro, mais là je ne peux résoudre mon problème sans le langage VBA. J'ai recherché quelques heures hier, mais sans succès.

Mon problème :
J'ai crée une macro qui filtre les données d'un tableau selon un critère d'équipement puis copie les pièces affectées sur cet équipement sur un autre tableau. Le problème est que ce mois si aucune pièces n'a été sortie sur un équipement. Quand je lance la macro, elle ne trouve pas le critère demandé (logiquement) et bug. J'aimerais rajouter une condition SI le critère n'est pas présent alors passer au deuxième critère. Je vous transmets ma ligne de code actuelle (les équipements sont 1, Video 1, 2 et 3).

Code: 
Sub pieces_generales2()
'
' pieces_generales2 Macro
' Tri les pieces par equipement
'

'
    Sheets("Calculs").Select
    Range("A16:E16").Select
    Selection.AutoFilter
    Range("D16").Select
    ActiveSheet.Range("$A$16:$E$37").AutoFilter Field:=4, Criteria1:="1" _
        , Operator:=xlOr, Criteria2:="=Vidéo 1"
    Range("A17:E49").Select
    Selection.Copy
    Range("I4").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    ActiveSheet.Range("$A$16:$E$37").AutoFilter Field:=4, Criteria1:="2"
    Range("A17:E51").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("O4").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    ActiveSheet.Range("$A$16:$E$37").AutoFilter Field:=4, Criteria1:="3"
    Range("A17:E50").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("U4").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("I4:M16").Select
    Application.CutCopyMode = False
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Range("A16:E16").Select
    Selection.AutoFilter
    Sheets("Calculs").Select
End Sub

Je ne peux pas vous transmettre le fichier pour des raisons de confidentialité. Je vous remercie par avance de votre aide.
 
Trier par date Trier par votes
youky(BJ)

youky(BJ)

XLDnaute Barbatruc
Re : Macro filtre bug car aucun critère

Bonjour john38,
Bienvenu au forum !
Voici une solution, tester le nombre de lignes restant après filtre.

if Application.SUBTOTAL(3,[A16:A65000])<1 Then exit sub

ceci fait que l'on quitte la macro si le nombre de ligne=0

Autre solution avec
On Error Resume next
'ligne ou l'erreur risque de se faire
if Err>0 then msgbox"Annulation":Exit sub

Bruno
 
Vote positif 0 Vote négatif
L

Legolas

XLDnaute Occasionnel
Re : Macro filtre bug car aucun critère

Bonjour,

Oui c'est possible.

Code: 
'Premier filtre
if Application.SUBTOTAL(3,[A16:A65000])<1 Then
    'ton code qui copie colle
end if

'Second filtre
if Application.SUBTOTAL(3,[A16:A65000])<1 Then
    'ton code qui copie colle
end if
...
 
Vote positif 0 Vote négatif
J

John38

XLDnaute Nouveau
Re : Macro filtre bug car aucun critère

J'ai une autre petite question, Il faut que je le colle au niveau de où ce code ? Je vous tiens au courant dans 1h du résultat je pars en réunion. Je vous remercie du temps que vous me consacrez.
 
Vote positif 0 Vote négatif
L

Legolas

XLDnaute Occasionnel
Re : Macro filtre bug car aucun critère

Re,

Je pense que cela doit ressembler à ceci :

Code: 
Sheets("Calculs").Select
Range("A16:E16").Select
Selection.AutoFilter
Range("D16").Select

'premier filtre
ActiveSheet.Range("$A$16:$E$37").AutoFilter Field:=4, Criteria1:="1" _
        , Operator:=xlOr, Criteria2:="=Vidéo 1"

'premier test
if Application.SUBTOTAL(3,[A16:A65000])<1 Then
   'si test ok, copie colle
   Range("A17:E49").Select
   Selection.Copy
   Range("I4").Select
   Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
end if

'second filtre
ActiveSheet.Range("$A$16:$E$37").AutoFilter Field:=4, Criteria1:="2"

'second test
if Application.SUBTOTAL(3,[A16:A65000])<1 Then
   'si test ok, copie colle
   Range("A17:E51").Select
   Application.CutCopyMode = False
   Selection.Copy
   Range("O4").Select
   Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
end if

'troisième filtre
ActiveSheet.Range("$A$16:$E$37").AutoFilter Field:=4, Criteria1:="3"

'troisième test
if Application.SUBTOTAL(3,[A16:A65000])<1 Then
   'si test ok, copie colle
   Range("A17:E50").Select
   Application.CutCopyMode = False
   Selection.Copy
   Range("U4").Select
   Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

'Faire la mise en forme
    Range("I4:M16").Select
    Application.CutCopyMode = False
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Range("A16:E16").Select
    Selection.AutoFilter
    Sheets("Calculs").Select

A plus !
 
Vote positif 0 Vote négatif
J

John38

XLDnaute Nouveau
Re : Macro filtre bug car aucun critère

J'ai trouvé il manquait un End If en revanche la macro ne marche pas. Elle s'execute sans erreur, mais les 2 tableaux qui devraient être remplis car il y a des pièces sorties sur ces équipements ne le sont pas. Je pense que la macro voit qu'il n'y a pas de données pour le première équipement elle s'arrête au lieu d'aller chercher les autres critères.
 
Vote positif 0 Vote négatif
L

Legolas

XLDnaute Occasionnel
Re : Macro filtre bug car aucun critère

Re,

Désolé pour l'oubli du End If
Par contre la macro ne s'arrete pas : il n'y a pas d' "Exit Sub" dans le code.
Quoi qu'il arrive les 3 filtres sont testés.

Sans fichier, c'est dur de se faire une idée de ce qu'il se passe.
Ne pouvez vous pas modifier les données pour qu'il ne soit plus confidentiel et nous faire parvenir une pièce jointe ?

A plus
 
Vote positif 0 Vote négatif
L

Legolas

XLDnaute Occasionnel
Re : Macro filtre bug car aucun critère

Complètement...
J'ai été un peu rapide dans le copier coller des codes.

Il faut mettre >0 sur tous les tests !

Le test sert à savoir s'il y a des données (ou non) :
- la première proposition de youky était : si pas de données sortir de la macro (donc test <1)
- ce que j'ai voulu faire : s'il y a des données, exécuter le copier coller (donc >0)

Désolé pour cette erreur de ma part.

A plus

PS : Et comme quoi, il vaut mieux marcher...
 
Vote positif 0 Vote négatif

Discussions similaires

R
  • Question
XL 2016 Rendre plus lisible un code VBA
2
Réponses
23
Affichages
1 K
TooFatBoy
TooFatBoy
H
  • Question
XL 2016 Mettre des titres avec une mise en forme spécifique
Réponses
1
Affichages
305
vgendron
vgendron
K
  • Question
XL 2019 Organiser le code VBA
Réponses
9
Affichages
599
Kevin38
K
L
  • Question
Microsoft 365 Changement de couleurs de cellules dans plusieurs feuilles suite à une modification
Réponses
4
Affichages
393
lolo_excelbeginner
L
F
  • Résolu(e)
XL 2021 Créer Macro permettant d'indexer des nouveaux clients ? [Résolu]
4 5 6
Réponses
82
Affichages
2 K
fanou06
F
F
  • Résolu(e)
Microsoft 365 Message Box oui/non
Réponses
2
Affichages
146
Francky79
F
R
  • Résolu(e)
XL 2019 creer une macro pour copier des info d un onglet a un autre dans le meme classeur
Réponses
4
Affichages
306
robpellan52
R
F
  • Question
Microsoft 365 Poursuivre ou pas la macro
Réponses
2
Affichages
228
Francky79
F
G
  • Résolu(e)
XL 2013 copier coller valeur d'une colonne dynamique
Réponses
13
Affichages
387
gwenn49
G
Syracoti
  • Résolu(e)
XL 2016 Changer de feuille dans une macro
2
Réponses
28
Affichages
3 K
Staple1600
Staple1600

Membres actuellement en ligne

33 membres et 483 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 463
Messages
2 088 615
Membres
103 892
dernier inscrit
alexandre.taccoen@halgand