Autres Suppression de lignes conditions multiples

[JBond13600]

Bonjour le Forum,

Malgré de multiples recherches sur l'ensemble des forums, rien ne correspond à ce que je recherche et m'adresse donc à vous en désespoir de cause.

Les lignes sont à traiter en fonction des valeurs de plusieurs colonnes qui sont au nombre de 9, de la colonne "H" à "P" inclus.

Il y a des lignes dont les colonnes "H" à "P" inclus sont toutes vides
Il y a des lignes où deux ou plusieurs colonnes de "H" à "P" contiennent une valeur, quelle qu'elle soit
Il y a des lignes où il n'y a qu'une seule valeur, quelle qu'elle soit, dans une seule des colonnes de "H" à "P" inclus.

Ce sont ces dernières lignes uniquement que je souhaite conserver.

Autrement dit, je ne souhaiterais conserver que les lignes où il n'y a qu'une seule valeur, qu'elle quelle soit, et qu'elle que soit la colonne de "H" à "P" inclus.

Le nombre de lignes à traiter par feuille est supérieur à 3000.

Excel 2007.

En fichier joint les données d'origine et le résultat attendu.

Un grand merci par avance.

 

[job75]

Bonjour JBond13600,

Plusieurs forums ??? Ceci est pourtant très classique :

Sub SupprimerLignes()
Application.ScreenUpdating = False
With ActiveSheet.UsedRange
    With .Columns(.Columns.Count + 1) 'colonne auxiliaire
        .FormulaR1C1 = "=1/(COUNTA(RC8:RC16)=1)" 'NBVAL
        .Value = .Value 'supprime les formules
        .EntireRow.Sort .Cells, xlAscending, Header:=xlNo 'tri pour grouper et accélérer
        On Error Resume Next 'si aucune SpecialCell
        .SpecialCells(xlCellTypeConstants, 16).EntireRow.Delete 'supprime les valeurs d'erreur
        .ClearContents 'RAZ
    End With
End With
End Sub

A+

 

[job75]

J'ai recopié la plage H1: P100 sur 50 000 lignes : chez moi la macro s'exécute en 3 secondes.

 

[JBond13600]

Super. Ca marche au top...

Un grand merci à toi.

Est-il envisageable que ce code s'applique sur la feuille active ainsi que sur toutes les feuilles suivantes, quelque soit leur nom, jusqu'à la dernière ?

 

[job75]

sur la feuille active ainsi que sur toutes les feuilles suivantes

Il suffit d'ajouter une boucle :

Sub SupprimerLignes()
Dim i%
Application.ScreenUpdating = False
For i = ActiveSheet.Index To Sheets.Count
    If TypeName(Sheets(i)) = "Worksheet" Then 's'il y a des feuilles Graphiques
        With Sheets(i).UsedRange
            With .Columns(.Columns.Count + 1) 'colonne auxiliaire
                .FormulaR1C1 = "=1/(COUNTA(RC8:RC16)=1)" 'NBVAL
                .Value = .Value 'supprime les formules
                .EntireRow.Sort .Cells, xlAscending, Header:=xlNo 'tri pour grouper et accélérer
                On Error Resume Next 'si aucune SpecialCell
                .SpecialCells(xlCellTypeConstants, 16).EntireRow.Delete 'supprime les valeurs d'erreur
                .ClearContents 'RAZ
            End With
        End With
    End If
Next
End Sub

 

[job75]

Juste une remarque : dans les feuilles traitées il faut qu'il y ait des données dans les colonnes P et/ou suivantes...

 

[JBond13600]

Il peut y avoir des données ou non dans les colonnes "H" à "P" inclus. Toutes les colonnes suivantes sont vides.
En revanches les colonnes "A" à "G" contiennent des informations à conserver.

Ton dernier code, dont je te remercie encore, fonctionne-t-il avec les dernières informations que je te livre dans ce présent post ?

 

[job75]

J'ai bien dit :

Juste une remarque : dans les feuilles traitées il faut qu'il y ait des données dans les colonnes P et/ou suivantes...

Si ce n'est pas le cas la feuille n'est pas modifiée car les formules entraînent des références circulaires et prennent la valeur zéro.

 

[JBond13600]

Ok, Ok...

 

[job75]

Bonjour JBond13600,

Ok mais on peut peaufiner.

Si la dernière colonne utilisée se trouve avant la colonne P cette macro évite les références circulaires :

Sub SupprimerLignes()
Dim i%, ncol%
Application.ScreenUpdating = False
For i = ActiveSheet.Index To Sheets.Count
    If TypeName(Sheets(i)) = "Worksheet" Then 's'il y a des feuilles Graphiques
        With Sheets(i).UsedRange
            ncol = .Columns.Count
            If .Columns(ncol).Column < 16 Then ncol = ncol + 16 - .Columns(ncol).Column
            With .Columns(ncol + 1) 'colonne auxiliaire
                .FormulaR1C1 = "=1/(COUNTA(RC8:RC16)=1)" 'NBVAL
                .Value = .Value 'supprime les formules
                .EntireRow.Sort .Cells, xlAscending, Header:=xlNo 'tri pour grouper et accélérer
                On Error Resume Next 'si aucune SpecialCell
                .SpecialCells(xlCellTypeConstants, 16).EntireRow.Delete 'supprime les valeurs d'erreur
                .ClearContents 'RAZ
            End With
        End With
    End If
Next
End Sub

A+