XL 2019 Filtre avancé + Colonnes spécifiques (VBA)

[Amilo]

Bonjour le forum,

J'aurais svp une nouvelle demande concernant mon précédent fil créé ici,
Dans le résultat du filtre avancé (onglet Résultat"), je souhaiterais pouvoir compléter librement des informations à côté de ma plage de résultat
Pour cela, j'ai ajouté 3 nouvelles colonnes "Commentaire", "Code" et "Mts" qui seront renseignées manuellement au fil du temps

Malheureusement, le code VBA actuel ne fonctionne pas dans ce cas précis.

En vous remerciant par avance pour votre aide

Cordialement

 

[fanfan38]

Bonjour
Le + simple est d'ajouter aussi ces 3 colonnes aux autres feuilles (quitte à les masquées)
A+ François

 

[Amilo]

Bonjour @fanfan38,
Merci pour cette proposition,
J'avais déjà testé plusieurs tentatives dont celle-ci mais cela m'écrase les valeurs que je rentre dans la feuille "Résultat".
Cela fonctionnerait seulement si je saisie les valeurs dans la feuille "Source" que je souhaite pas.
J'ai également essayé d'adapter le code VBA, en indiquant des plages mais en vain.
Merci en tout cas.
Cordialement

 

[cp4]

Bonjour,

@Amilo : Si j'ai bien compris

Sub Extrait()
  Sheets("source").Range("A3:C15").AdvancedFilter Action:=xlFilterCopy, _
    CriteriaRange:=Sheets("critères").Range("A3:C5"), CopyToRange:=Range( _
      "Résultat!Extract"), Unique:=False
End Sub

Bon week-end.

 

[Amilo]

Bonjour @cp4 ,

Merci également pour votre message,
Cela fonctionne effectivement mais j'ai plusieurs craintes :
- je dois encore le tester sur un fichier de 20 000 lignes env. pour voir la durée d'exécution,
- et aussi, le décalage des valeurs si j'ajoute un nouveau critère dans ma zone.
Par exemple, si dans ma zone de critères j'ai 12 et 13 et que j'ajoute un 3ème critère par exemple le 11, cela va me décaler les commentaires sur les mauvaises lignes.
En principe ma zone de critères ne devrait plus changer mais j'aimerais prendre toutes les précautions.

Merci

Cordialement

 

[cp4]

Dans la 1ère macro, le résultat n'était effacé. Si j'ai bien compris ta demande.

Sub Extrait()
Dim t As Single
t = Timer
Application.ScreenUpdating = False
Sheets("Résultat").Range("A3").CurrentRegion.Offset(1).ClearContents

  Sheets("source").Range("A3:C15").AdvancedFilter Action:=xlFilterCopy, _
    CriteriaRange:=Sheets("critères").Range("A3:C5"), CopyToRange:=Range( _
      "Résultat!Extract"), Unique:=False
Application.ScreenUpdating = False
MsgBox (Timer - t) / 1000 & " milliseconde"
End Sub

 

[Amilo]

Merci @cp4 , je testerai en soirée dès que je serai rentré.
Cordialement

 

[Amilo]

Re,
Je viens de tester le code de @cp4 (#6) avec une légère modification sur la 5ème ligne (test sur un fichier de 45000 lignes) :
- C'est très rapide (0,00025 milliseconde) et c'est parfait du côté durée d'exécution même avec un gros fichier
- Le seul problème est que les commentaires se décalent à l'ajout d'un nouveau critère
J'ai mis 2 captures pour illustrer ce problème avant et après modification de la zone de critères

Cordialement

Sub Extrait()
Dim t As Single
t = Timer
Application.ScreenUpdating = False
Sheets("Résultat").Range("A3:C15").ClearContents

  Sheets("Source").Range("A3:C15").AdvancedFilter Action:=xlFilterCopy, _
    CriteriaRange:=Sheets("critères").Range("A3:C6"), CopyToRange:=Range( _
      "Résultat!Extract"), Unique:=False
Application.ScreenUpdating = False
MsgBox (Timer - t) / 1000 & " milliseconde"
End Sub

 

[cp4]

Re,
Je viens de tester le code de @cp4 (#6) avec une légère modification sur la 5ème ligne (test sur un fichier de 45000 lignes) :
- C'est très rapide (0,00025 milliseconde) et c'est parfait du côté durée d'exécution même avec un gros fichier
- Le seul problème est que les commentaires se décalent à l'ajout d'un nouveau critère
J'ai mis 2 captures pour illustrer ce problème avant et après modification de la zone de critères

Cordialement

Sub Extrait()
Dim t As Single
t = Timer
Application.ScreenUpdating = False
Sheets("Résultat").Range("A3:C15").ClearContents

  Sheets("Source").Range("A3:C15").AdvancedFilter Action:=xlFilterCopy, _
    CriteriaRange:=Sheets("critères").Range("A3:C6"), CopyToRange:=Range( _
      "Résultat!Extract"), Unique:=False
Application.ScreenUpdating = False
MsgBox (Timer - t) / 1000 & " milliseconde"
End Sub

Bonjour,
Voici le code modifié pour des plages dynamiques.
Pour le décalage, je n'ai pas compris. Si tes commentaires sont mis après un filtrage, c'est normal qu'au filtrage suivant il y a un décalage car c'est autre filtrage avec des critères différents.

Sub Extrait1()
Dim t As Single, Ps As Range, Pc As Range
t = Timer
Set Ps = Sheets("source").Range("A3").CurrentRegion 'plage de données sources
Set Pc = Sheets("critères").Range("A3").CurrentRegion 'plage de critères

Application.ScreenUpdating = False
Sheets("Résultat").Range("A3").CurrentRegion.Offset(1).ClearContents 'effacer precedent resultat du filtre

  Ps.AdvancedFilter Action:=xlFilterCopy, _
    CriteriaRange:=Pc, CopyToRange:=Range( _
      "Résultat!Extract"), Unique:=False        'Nouveau filtre élaborcé

Application.ScreenUpdating = False
MsgBox (Timer - t) / 1000 & " ms"

Set Ps = Nothing
Set Pc = Nothing
End Sub

 

[Amilo]

Bonjour @cp4 ,
Merci encore pour ce code,
Je vais le tester pour voir mais je pense qu'il fonctionnera sans problème.
Concernant le décalage, je pensais qu'il serait possible avec VBA.
Je vais sinon utiliser Power Query qui le fait assez facilement pour cette 2ème partie.
Encore merci à tous pour votre aide
Cordialement