XL 2016 Copier des valeurs après filtrage avec exclusion

[Stéfane]

Bonjour à tous,

Je suis à la recherche d'une solution (si cela est possible vba) pour, exclure, dans une colonne filtrée, la valeur qui est la plus présente, pour pouvoir copier coller les autres valeurs.
Je vous joint un fichier qui explique plus clairement ma recherche.

Merci à tous pour votre aide.

 

[job75]

Bonsoir Stéfane,

Le code de Feuil Résultats :

Private Sub Worksheet_Activate()
Application.ScreenUpdating = False
[A8].Resize(Rows.Count - 7).Clear 'RAZ
[M8].Resize(Rows.Count - 7).Clear 'RAZ
With Sheets("Feuille départ").[A1].CurrentRegion
    .AutoFilter 10, .Cells(1, 10)
    .AutoFilter 13, "<>" & Replace(.Cells(1, 13), ",", ".")
    On Error Resume Next
    Intersect(.Columns(5), .Offset(1)).Copy [A8]
    Intersect(.Columns(13), .Offset(1)).Copy [M8]
    .AutoFilter 13 'facultatif
End With
End Sub

A+

 

[Stéfane]

Bonsoir Job75,

Merci pour votre aide

Cela fonctionne effectivement parfaitement sur le dossier joint, cependant je rencontre un problème lorsque j' intégrer cette macro avec d'autre :
la première partie de ma macro filtre les valeurs récurrente (celles que souhaite ne pas prendre en compte dans la macro souhaité) et une autre qui filtre les valeurs des colonnes à 0.
La macro souhaité viens donc à la suite en dernière position
De ce fait la fonction 'RAZ de votre macro efface des chiffres déjà intégrés dans mon tableau ''Feuille résultat''.

Vous allez me dire qu'il suffit d'en inverser l'ordre pour résoudre le problème mais je ne peux pas car je suis obliger de réaliser cela dans un ordre précis.

Pensez vous qu'il soit possible de ne pas effacer ?

Merci pour votre aide.

 

[Stéfane]

Je pense comprendre le fonctionnement.
En fait à chaque changement de numéro dans la cases ''marrons'' ''numéro de série'' la macro efface les anciennes valeurs pour mettre les nouvelles.
Ma recherche consiste à l'inverse à mettre à la suite a chaque filtrage sans effacer les anciennes valeur déjà filtrées.
Merci pour votre aide.

 

[job75]

Ma macro fait ce que vous avez demandé dans Feuil Résultats.

C'est à dire coller les zones filtrées en A8 et M8.

Vous pouvez neutraliser les effacements (RAZ), vous verrez bien ce que ça donne.

Maintenant dans certains cas la macro n'allait pas bien, ce fichier (2) est mieux :

Private Sub Worksheet_Activate()
Application.ScreenUpdating = False
[A8].Resize(Rows.Count - 7).Clear 'RAZ
[M8].Resize(Rows.Count - 7).Clear 'RAZ
With Sheets("Feuille départ").[A1].CurrentRegion
    .AutoFilter 10, .Cells(1, 10).Text
    .AutoFilter 13, "<>" & Replace(.Cells(1, 13).Text, ",", ".")
    On Error Resume Next 'si aucune SpecialCell
    Intersect(.Columns(5), .Offset(1)).SpecialCells(xlCellTypeVisible).Copy [A8]
    Intersect(.Columns(13), .Offset(1)).SpecialCells(xlCellTypeVisible).Copy [M8]
    .AutoFilter 13 'facultatif
End With
End Sub

Bonne nuit.

 

[job75]

Bonjour Stéfane,

Si l'on veut mémoriser les filtrages voyez ce fichier (3) et les macros des 2 boutons :

Private Sub CommandButton1_Click() 'bouton Filtrer
Dim c1 As Range, c2 As Range
If MsgBox("Voulez-vous mémoriser le filtrage dans 'Feuil Résultats' ?", 4) = 6 Then
    With Sheets("Feuil Résultats")
        If .FilterMode Then .ShowAllData 'si la feuille est filtrée
        Set c1 = .Cells(.Rows.Count, 1).End(xlUp)(2)
        Set c2 = .Cells(.Rows.Count, 13).End(xlUp)(2)
        If c1.Row > c2.Row Then Set c2 = c1(1, 13)
        If c1.Row < c2.Row Then Set c1 = .Cells(c2.Row, 1)
    End With
End If
With [A1].CurrentRegion
    .AutoFilter 10, .Cells(1, 10).Text
    .AutoFilter 13, "<>" & Replace(.Cells(1, 13).Text, ",", ".")
    If c1 Is Nothing Then Exit Sub
    On Error Resume Next 'si aucune SpecialCell
    Intersect(.Columns(5), .Offset(1)).SpecialCells(xlCellTypeVisible).Copy c1
    Intersect(.Columns(13), .Offset(1)).SpecialCells(xlCellTypeVisible).Copy c2
    Application.Goto c1, True 'cadrage
End With
End Sub

Private Sub CommandButton2_Click() 'bouton RAZ
If FilterMode Then ShowAllData
End Sub

A+

 

[job75]

Bah il vaut mieux que la question soit posée après le filtrage, fichier (4) :

Private Sub CommandButton1_Click() 'bouton Filtrer
Dim c1 As Range, c2 As Range
With [A1].CurrentRegion
    .AutoFilter 10, .Cells(1, 10).Text
    .AutoFilter 13, "<>" & Replace(.Cells(1, 13).Text, ",", ".")
    If MsgBox("Voulez-vous mémoriser le filtrage dans 'Feuil Résultats' ?", 4, "Filtrer") = 7 Then Exit Sub
    With Sheets("Feuil Résultats")
        If .FilterMode Then .ShowAllData 'si la feuille est filtrée
        Set c1 = .Cells(.Rows.Count, 1).End(xlUp)(2)
        Set c2 = .Cells(.Rows.Count, 13).End(xlUp)(2)
        If c1.Row > c2.Row Then Set c2 = c1(1, 13)
        If c1.Row < c2.Row Then Set c1 = .Cells(c2.Row, 1)
    End With
    On Error Resume Next 'si aucune SpecialCell
    Intersect(.Columns(5), .Offset(1)).SpecialCells(xlCellTypeVisible).Copy c1
    Intersect(.Columns(13), .Offset(1)).SpecialCells(xlCellTypeVisible).Copy c2
    Application.Goto c1, True 'cadrage
End With
End Sub

Private Sub CommandButton2_Click() 'bouton RAZ
If FilterMode Then ShowAllData
End Sub

 

[Stéfane]

Bonjour Job75

Juste parfait!!

Les 2 fonctionnent parfaitement et correspondent tout à fait à ce que je cherche.
La question ''MsgBox'' n'a pas d'importance, je l'ai enlevée car comme je le disait j'intègre votre macro avec d'autres, car je copie la valeur récurrente pour l'inscrire dans une case d'une autre feuille, puis sur les colonnes pour lesquelles la valeurs récurrente est 0 mais pour lesquelles des valeurs autres que zéro existent dans la colonne est enfin avec la votre pour filtrer les valeurs de la colonne pour lesquelles il y a une valeur récurrentes + d'autres aleurs.
De cette façon je filtre toutes les valeurs dont j'ai besoin.
J'enchaine ainsi tous les numéros de série dans la même macro pour pouvoir obtenir les résultats sans avoir à cliquer sur chaque numéro de série à chaque fois. (J'automatise en quelque sorte avec ''Call macro1 (valeur récurrente case marron) , Call macro2 (valeur récurrente = 0 mais valeur dans la colonne) et la votre.

Merci encore beaucoup pour votre aide et je vous souhaite une très bonne après midi.