Ajout de critère sur une macro

Créer une discussion
Répondre
  • Initiateur de la discussion Initiateur de la discussion aperez
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
A

aperez

XLDnaute Nouveau
Bonjour le forum,

Alors voilà grace a l'aide du forum j'ai une macro qui fonctionne parfaitemt. Mais j'aurai besoin d'une petite aide. Ma macro consiste a recupérer des données d'une dizaine de feuille, pour les copier dans une feuille principale.

Cette macro regroupe des données de plusieurs feuilles, pour les mettre dans une seule feuille en fonction d'un critère nommé "NG1". Mais je doi rajouté un autre critère (nommé "NG.1") dans cette macro, chose que je n'arrive pa a faire.... La ligne indiquée en rouge est celle a modifier.

N'arrivan pa à rajouter le critère "NG.1" j'ai pensé que la solution pouvai etre de créer une deuxieme macro similaire a celle-ci, pui une 3ème qui serai une fusion des deux premieres.

Si qqun a une petite idée sur les sujets abordés, tte proposition est la bienvenue !
J'espere avoir été clair dans mes explications, si ce n'est pas le cas je reformulerai



CODE :

Sub NextGate1()
'
' Macro

Application.ScreenUpdating = False

Sheets("ASIA").Select
Range("B4:R115").Select
Selection.Copy
Sheets("Next Gate 1").Select
Range("B1012").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("AUS").Select
Range("B4:R115").Select
Selection.Copy
Sheets("Next Gate 1").Select
Range("B340").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("EUR").Select
Range("B4:R115").Select
Selection.Copy
Sheets("Next Gate 1").Select
Range("B900").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("FR").Select
Range("B4:R115").Select
Selection.Copy
Sheets("Next Gate 1").Select
Range("B4").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("GER").Select
Range("B4:R115").Select
Selection.Copy
Sheets("Next Gate 1").Select
Range("B452").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("IND").Select
Range("B4:R115").Select
Selection.Copy
Sheets("Next Gate 1").Select
Range("B676").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("PMO").Select
Range("B4:R115").Select
Selection.Copy
Sheets("Next Gate 1").Select
Range("B564").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("ROW").Select
Range("B4:R115").Select
Selection.Copy
Sheets("Next Gate 1").Select
Range("B788").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("UK").Select
Range("B4:R115").Select
Selection.Copy
Sheets("Next Gate 1").Select
Range("B116").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("USA").Select
Range("B4:R115").Select
Selection.Copy
Sheets("Next Gate 1").Select
Range("B228").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Range("A1:A2").Select
Selection.AutoFilter Field:=18, Criteria1:="NG1"
Range("A1:A2").Select
Sheets("FR").Select
Sheets("UK").Select
Sheets("USA").Select
Sheets("USA").Select
Sheets("GER").Select
Sheets("PMO").Select
Sheets("IND").Select
Sheets("ROW").Select
Sheets("EUR").Select
Sheets("ASIA").Select
Range("A1:A2").Select

' codes ci-dessous optionnels. Possible de les effacer (hormis la ligne "End Sub")
Range("A1").Select
Sheets("UK").Select
Range("A1").Select
Sheets("Next Gate 1").Select
Range("A1").Select
Range("A1").Select
Sheets("USA").Select
Range("A1").Select
Sheets("Next Gate 1").Select
Range("A1").Select
Range("A1").Select
Sheets("AUS").Select
Range("A1").Select
Sheets("Next Gate 1").Select
Range("A1").Select
Range("A1").Select
Sheets("GER").Select
Range("A1").Select
Sheets("Next Gate 1").Select
Range("A1").Select
Range("A1").Select
Sheets("PMO").Select
Range("A1").Select
Sheets("Next Gate 1").Select
Range("A1").Select
Range("A1").Select
Sheets("IND").Select
Range("A1").Select
Sheets("Next Gate 1").Select
Range("A1").Select
Range("A1").Select
Sheets("ROW").Select
Range("A1").Select
Sheets("Next Gate 1").Select
Range("A1").Select
Range("A1").Select
Sheets("EUR").Select
Range("A1").Select
Sheets("Next Gate 1").Select
Range("A1").Select
Range("A1").Select
Sheets("ASIA").Select
Range("A1").Select
Sheets("Next Gate 1").Select
Range("A1").Select

Application.ScreenUpdating = True
End Sub
 
Trier par date Trier par votes
Re : Ajout de critère sur une macro

Salut aperez et le forum,

V'là une belle construction de code par macro "apprentissage". Moi, je la préfère comme ceci (mais, je ne l'ai pas testée
Code: 
Sub NextGate1()
On Error GoTo Err_NextGate1
' Macro
'Blocage raffraîchissement écran
Application.ScreenUpdating = False
 
'Activation feuille
Sheets("Next Gate 1").Activate
 
'copie de la plage
'cologa spécial sur feuille active
 
Sheets("ASIA").Range("B4:R115").Copy
Range("B1012").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
 
Sheets("AUS").Range("B4:R115").Copy
Range("B340").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
 
Sheets("EUR").Range("B4:R115").Copy
Range("B900").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
 
Sheets("FR").Range("B4:R115").Copy
Range("B4").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
 
Sheets("GER").Range("B4:R115").Copy
Range("B452").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
 
Sheets("IND").Range("B4:R115").Copy
Range("B676").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
 
Sheets("PMO").Range("B4:R115").Copy
Range("B564").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
 
Sheets("ROW").Range("B4:R115").Copy
Range("B788").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
 
Sheets("UK").Range("B4:R115").Copy
Range("B116").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
 
Sheets("USA").Range("B4:R115").Copy
Range("B228").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
 
'------------------------------------------------------------
With Range("A1").CurrentRegion
    ActiveSheet.AutoFilterMode = False
    .AutoFilter Field:=18, Criteria1:="NG1"
End With
'------------------------------------------------------------
Sortie_NextGate1:
    Application.ScreenUpdating = True
    Exit Sub
Err_NextGate1:
    MsgBox (Err.Number & " - " & Err.Description)
    Resume Sortie_NextGate1
End Sub
Différences essentielles avec l'originale :
- Disparition des select qui ralentissent le code.
- Gestion des erreurs => si tu ne gères pas les erreurs, Excel bloque le rafraîchissement écran, c'est super, mais si pour une raison quelconque, excel passe en erreur,(je sais, c'est impossible, ça n'arrive jamais), il arrête la macro à la ligne de l'erreur et il sort => il n'exécute jamais la remise en route du rafraîchissement écran. Et, cerise sur le gâteau, il ne te prévient pas. => et si tu lances un autre fichier Excel, lui non plus ne l'a pas le rafraîchissement, et tu ne le sais toujours pas.
Si tu utilises une instruction concernant Application, gère les erreurs, ça t'évitera de porter une perruque, pour cause de trou dans la cheveulure.


Cette macro regroupe des données de plusieurs feuilles, pour les mettre dans une seule feuille en fonction d'un critère nommé "NG1". Mais je doi rajouté un autre critère (nommé "NG.1") dans cette macro, chose que je n'arrive pa a faire.... La ligne indiquée en rouge est celle a modifier.
Je dois être Daltonien 😛

Je suppose que tu cherches à ajouter un second critère au filtre automatique ?
Mais lequel ?
.AutoFilter Field:=18, Criteria1:="NG1", Operator:=xlOr, _
Criteria2:="NG.1"
ou
.AutoFilter Field:=18, Criteria1:="NG1"
.AutoFilter Field:=19, Criteria1:="NG.1"
à la place de l'équivalent dans la section With

CurrentRegion, je le met systèmatiquement depuis qu'une série de critères ne fonctionnait qu'avec
A+
 
Vote positif 0 Vote négatif
Re : Ajout de critère sur une macro

Bonsoir, aperez, Gorfael, tu m'a devancé de qques minutes.
Effectivement le code, lourd, très lourd..
Un peu diminué (pour ma part, testé), en supposant que la colonne B soit remplie à chaque fois....:

Sub NextGate1()
Application.ScreenUpdating = False
With Sheets("Next Gate 1")
Sheets("FR").Range("B4:R" & Sheets("FR").[b65000].End(xlUp).Row).Copy
.Range("B4").PasteSpecial Paste:=xlPasteValues
Sheets("UK").Range("B4:R" & Sheets("UK").[b65000].End(xlUp).Row).Copy
.Range("B" & .[a65000].End(xlUp).Row + 1).PasteSpecial Paste:=xlPasteValues
Sheets("USA").Range("B4:R" & Sheets("USA").[b65000].End(xlUp).Row).Copy
.Range("B228").PasteSpecial Paste:=xlPasteValues
Sheets("AUS").Range("B4:R" & Sheets("AUS").[b65000].End(xlUp).Row).Copy
.Range("B340").PasteSpecial Paste:=xlPasteValues
Sheets("GER").Range("B4:R" & Sheets("GER").[b65000].End(xlUp).Row).Copy
.Range("B452").PasteSpecial Paste:=xlPasteValues
Sheets("PMO").Range("B4:R" & Sheets("PMO").[b65000].End(xlUp).Row).Copy
.Range("B564").PasteSpecial Paste:=xlPasteValues
Sheets("IND").Range("B4:R" & Sheets("IND").[b65000].End(xlUp).Row).Copy
.Range("B676").PasteSpecial Paste:=xlPasteValues
Sheets("ROW").Range("B4:R" & Sheets("ROW").[b65000].End(xlUp).Row).Copy
.Range("B788").PasteSpecial Paste:=xlPasteValues
Sheets("EUR").Range("B4:R" & Sheets("EUR").[b65000].End(xlUp).Row).Copy
.Range("B900").PasteSpecial Paste:=xlPasteValues
Sheets("ASIA").Range("B4:R" & Sheets("ASIA").[b65000].End(xlUp).Row).Copy
.Range("B1012").PasteSpecial Paste:=xlPasteValues
.[a1].AutoFilter Field:=18, Criteria1:="NG1", Operator:=xlOr, _
Criteria2:="=NG.1"
.[a1].Select
End With
Application.ScreenUpdating = True
End Sub
 
Vote positif 0 Vote négatif
Re : Ajout de critère sur une macro

Bonjour Forum, bhbh, et Gorfael

Oui javoue que ma macro etai assez lourde, jsui pa encore un expert là dedans, je my sui mi ya peu de tps. Alors desolé gorfael la ligne supposée etre en rouge n'est pa sortie .... 🙂 Mais comme vous m'avez conseillé j'ai simplifié tte cette grosse macro, et mon problème est résolu !
Je souhaitai ajouté un critère comme tu l'a di gorfael, et je me sui servi de ca :
.AutoFilter Field:=18, Criteria1:="NG1", Operator:=xlOr, _
Criteria2:="NG.1"

Cette fois ci c bien en rouge, et je te remercie pour ce coup de main gorfael, et merci a toi aussi bhbh !!!
Maintenan ca marche a merveille.

A bientot et encore merci !
 
Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

arck
  • Résolu(e)
XL 2019 Renvoyé à la ligne suivante si la ligne demandé n'est pas libre
Réponses
9
Affichages
200
Phil69970
Phil69970
arck
  • Résolu(e)
XL 2019 macro avec fonction copié coller si rempli par la macro
Réponses
12
Affichages
432
AtTheOne
AtTheOne
ph.vanne
  • Question Question
Autres fenêtre "Publication"
Réponses
10
Affichages
656
ph.vanne
ph.vanne
N
  • Résolu(e)
Microsoft 365 Macro entre 2 classeurs
2
Réponses
19
Affichages
514
Nounours4173
N
H
  • Résolu(e)
XL 2016 Copier cellule dans un autre onglets
2
Réponses
16
Affichages
789
Phil69970
Phil69970
richardlion
  • Question Question
XL 2016 copier valeur actuel
2
Réponses
18
Affichages
427
sylvanu
sylvanu
X
  • Question Question
XL 2021 Transformation de données sur une ligne en plusieurs lignes
Réponses
9
Affichages
411
xavieralvaro
X
C
  • Question Question
Microsoft 365 Enregistrer via VBA sans ouvrir fichier
Réponses
9
Affichages
427
cdric78
C
M
  • Question Question
XL 2021 VBA Excel Erreur 2023
Réponses
2
Affichages
346
MICHIS
M
micie1509
  • Résolu(e)
XL 2021 Exécuter une macro sur plusieurs feuilles
Réponses
9
Affichages
553
micie1509
micie1509
S
  • Résolu(e)
Microsoft 365 VBA Concaténer contenu de plusieurs cellules dans une seule avec séparateurs / évolutifs
Réponses
3
Affichages
461
spike29
S
M
  • Question Question
Microsoft 365 deux macros succesives et un bouton
2
Réponses
17
Affichages
1 K
MICHAEL
M
eastwick
  • Résolu(e)
XL 2016 macro fichier fermé
Réponses
1
Affichages
138
eastwick
eastwick
N
  • Résolu(e)
Microsoft 365 Macro copier/coller entre deux tableaux structurés
3 4 5
Réponses
66
Affichages
2 K
job75
job75
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
721
robpellan52
R
M
  • Résolu(e)
XL 2021 Problème d'activation d'une macro pour transférer des valeurs d'une feuille 1 à une feuille 2
Réponses
3
Affichages
182
MATLEA
M
B
  • Question Question
XL 2019 Dans une macro de démarrage de fichier masquer le code par des Astérix ou point
Réponses
3
Affichages
441
sylvanu
sylvanu
G
  • Résolu(e)
XL 2013 copier coller valeur d'une colonne dynamique
Réponses
13
Affichages
809
gwenn49
G
T
  • Résolu(e)
Microsoft 365 VBA Exporter une sélection de plages nommées au format PDF
Réponses
12
Affichages
965
tnion
T
V
  • Question Question
XL pour MAC outil coller le contenu du presse papier
Réponses
2
Affichages
698
Valter
V
Retour