XL 2016 Macro sur Filtre

Anto35200

XLDnaute Occasionnel
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.
 

Pièces jointes

  • Filtre sur une unité.xlsx
    9.9 KB · Affichages: 7

Anto35200

XLDnaute Occasionnel
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.
 

Pièces jointes

  • Fichier macros.xlsx
    11.9 KB · Affichages: 1

job75

XLDnaute Barbatruc
S'il n'y a pas beaucoup de lignes :
VB:
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.
 

Pièces jointes

  • Fichier macros(1).xlsm
    18.9 KB · Affichages: 2

job75

XLDnaute Barbatruc
Si le tableau est dans un autre fichier il faut ouvrir ce fichier :
VB:
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.
 

Pièces jointes

  • Fichier macros(2).xlsm
    19.1 KB · Affichages: 6
  • Filtre sur une unité.xlsx
    9.9 KB · Affichages: 5

job75

XLDnaute Barbatruc
Cette macro fonctionne quels que soient le nom du fichier et le nombre de lignes :
VB:
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.
 

Pièces jointes

  • Fichier macros(3).xlsm
    20.4 KB · Affichages: 4
  • Filtre sur une unité.xlsx
    9.9 KB · Affichages: 4

Anto35200

XLDnaute Occasionnel
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.
 

Pièces jointes

  • FileName.xlsx
    11.5 KB · Affichages: 1
  • Fichier macros.xlsm
    23.6 KB · Affichages: 2

job75

XLDnaute Barbatruc
Bonsoir Anto35200,

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

En utilisant l'instruction :
VB:
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) :
VB:
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.
 

Pièces jointes

  • Fichier macros.xlsm
    23.9 KB · Affichages: 1
  • FileName.xlsx
    11.7 KB · Affichages: 2

Discussions similaires

Réponses
40
Affichages
2 K
Réponses
5
Affichages
114

Statistiques des forums

Discussions
312 934
Messages
2 093 736
Membres
105 803
dernier inscrit
metroMBP