XL 2016 Macro sur Filtre

[Anto35200]

Bonjour,
Je ne sais pas comment faire une macro sur un Filtre.
En effet, dans le fichier joint, je souhaiterai mettre une macro sur la colonne B, en supprimant les noms des mécaniciens avec 1 seul nom.

Par exemple, je voudrai supprimer les lignes B, C et F où il y a 1 seul nom.
J'espère être clair dans mes explications.

Je vous remercie de vitre aide.

 

[job75]

Bonjour Anto35200,

Entrez en C2 la formule :

=ESTNUM(TROUVE(";";B2))

et filtrez le tableau sur la colonne C.

A+

 

[Anto35200]

Merci.
C'est presque çà, mais je voudrai à partir de mon "Fichier macros" que la macro supprime les noms unique dans le fichier "Filtre sur unité" de la colonne B ?
Est-ce que c'est possible ? Je n'ai pas été clair dans mes explications.

 

[job75]

S'il n'y a pas beaucoup de lignes :

Sub Sup()
Dim i&
Application.ScreenUpdating = False
With [A1].CurrentRegion
    For i = .Rows.Count To 2 Step -1
        If InStr(.Cells(i, 2), ";") = 0 Then .Rows(i).Delete xlUp
    Next
End With
End Sub

Sinon utilisez un tableau VBA.

 

[job75]

Si le tableau est dans un autre fichier il faut ouvrir ce fichier :

Sub Sup()
Dim i&
Application.ScreenUpdating = False
Workbooks.Open ThisWorkbook.Path & "\Filtre sur une unité.xlsx"
With ActiveWorkbook.Sheets(1).[A1].CurrentRegion
    For i = .Rows.Count To 2 Step -1
        If InStr(.Cells(i, 2), ";") = 0 Then .Rows(i).Delete xlUp
    Next
End With
End Sub

On suppose ici que les 2 fichiers sont dans le même dossier.

 

[Anto35200]

Merci.
Si dans le fichier "Filtre sur une unité" il y a plusieurs lignes. Comment déterminer pour que le code sélectionne jusqu'à la dernière ligne vide ?


En te remerciant beaucoup de ton aide.

 

[job75]

Bonjour Anto35200, le forum,

CurrentRegion va jusqu'à la dernière ligne remplie.

A+

 

[job75]

Cette macro fonctionne quels que soient le nom du fichier et le nombre de lignes :

Sub Sup()
Dim fichier As Variant, tablo, n&, i&
ChDir ThisWorkbook.Path
fichier = Application.GetOpenFilename("Fichiers Excel(*.xls*),*.xls*")
If fichier = False Then Exit Sub
With Workbooks.Open(fichier).Sheets(1).[A1].CurrentRegion.Resize(, 2)
    tablo = .Value
    n = 1
    For i = 2 To UBound(tablo)
        If InStr(tablo(i, 2), ";") Then
            n = n + 1
            tablo(n, 1) = tablo(i, 1)
            tablo(n, 2) = tablo(i, 2)
        End If
    Next
    '---restitution---
    If .Parent.FilterMode Then .Parent.ShowAllData 'si la feuille est filtrée
    .Resize(n) = tablo
    .Offset(n).Resize(Rows.Count - n - .Row + 1).Delete xlUp 'RAZ en dessous
End With
End Sub

Elle est très rapide car elle utilise un tableau VBA.

 

[Anto35200]

Bonsoir job75,

J'ai adapté ton code sur mon fichier joint, mais j'avoue que je ne comprends pas trop. Il ne supprime pas les signataires uniques (dans le fichier FilName, colonne H.)
En remerciant beaucoup de ton aide.

 

[job75]

Bonsoir Anto35200,

Ce n'est pas le même problème puisque maintenant il y a 10 colonnes.

En utilisant l'instruction :

MsgBox ActiveWorkbook.Sheets(1).[H1].CurrentRegion.Address

on voit que CurrentRegion correspond à A1:J70, donc tout le tableau.

Par ailleurs en colonne H ce n'est plus le point-virgule mais la virgule.

Donc voici la macro adaptée pour traiter la colonne H (8ème colonne) :

Sub Sup()
Dim fichier As Variant, tablo, n&, i&, j%
ChDir ThisWorkbook.Path
fichier = Application.GetOpenFilename("Fichiers Excel(*.xls*),*.xls*")
If fichier = False Then Exit Sub
With Workbooks.Open(fichier).Sheets(1).[A1].CurrentRegion.Resize(, 10)
    tablo = .Value
    n = 1
    For i = 2 To UBound(tablo)
        If InStr(tablo(i, 8), ",") Then 'recherche la virgule
            n = n + 1
            For j = 1 To 10
                tablo(n, j) = tablo(i, j)
            Next j
        End If
    Next i
    '---restitution---
    If .Parent.FilterMode Then .Parent.ShowAllData 'si la feuille est filtrée
    .Resize(n) = tablo
    .Offset(n).Resize(Rows.Count - n - .Row + 1).Delete xlUp 'RAZ en dessous
End With
End Sub

Bonne nuit.

 

[Anto35200]

Bonsoir job75,

Un grand merci à toi !
Bonne nuit et bonne vacances !