Macro suppression lignes sauf 2 exceptions

Le 10/07/2017 à 10:27

Bonjour à tous,

Je vous explique mon problème.

J'ai le fichier excel que je vous joins et dans celui-ci j'ai un certain nombre de données à trier. Tout faire à la main est un calvaire du coup je me suis dit que j'allais faire un peu de VBA. Seulement, le VBA je n'en ai jamais fait.

Dans mon excel, j'ai une première ligne représentant des stations météorologiques (avec un numéro d'identification). Le reste ce sont des données liées à ces stations. Pour mon étude, je n'ai besoin que des stations portant les numéros d'identification 7481 et 7149. Je me suis dit que l'idéal serait de faire une boucle for et si le contenu de la cellule de la première colonne pour une ligne définie est différent de ces 2 nombres alors je dégage toute la ligne.

Comme ça le résultat devrait m'amener avec une dizaine de lignes représentant l'évolution des données de ces stations sur le mois de janvier (j'ai enlevé la plupart des données car il était trop lourd)

Niveau VBA, j'ai essayé de pondre un truc :

Sub Effacer()

'

' Effacer Macro

' garder uniquement 7149 et 7481

'

Dim compteur As Long

For compteur = 2 To Range("janvier 2017").Rows.Count

If (Cells(compteur, 1).Value <> (7149 And 7481)) Then Cells(compteur, 1).EntireRow.Delete

End If

Next

'

Application.Goto Reference:="Effacer"

End Sub

Malheureusement beaucoup de rouge et comme je ne connais pas la syntaxe VBA, je perds énormément de temps.

Est-ce que quelqu'un pourrait me dépanner ?

Merci d'avance !

19test-janvier-2017.csv (11.63 Ko)
Le 10/07/2017 à 11:12

Bonjour,

ce code devrait résoudre ton souci :

    With ActiveSheet
        .Range(.Rows(1), .Rows(7148)).Delete
        .Range(.Rows(7150), .Rows(7480)).Delete
        .Range(.Rows(7482), .Rows(.UsedRange.Rows.Count)).Delete
    End With
Le 10/07/2017 à 13:59

Bonjour,

Sub Test()
    Dim tbl, sta, k%, i%, j%
    sta = Array(7149, 7481)
    With Worksheets(1)
        k = .Cells(1, .Columns.Count).End(xlToLeft).Column
        For i = 0 To UBound(sta)
            j = WorksheetFunction.Match(sta(i), .Columns(1), 0)
            tbl = .Cells(j, 1).Resize(, k).Value
            .Rows(2 + i).Insert
            .Cells(2 + i, 1).Resize(, k).Value = tbl
        Next i
        .Rows(2 + i).Insert
    End With
End Sub

Lancer à partir de la boîte de dialogue macro pour tester.

La ligne .Rows(2 + i).Insert (la dernière hors boucle) ne vise qu'à ne pas supprimer le reste de la feuille lors de test. A remplacer normalement par :

        .UsedRange.Offset(i + 1).Clear

Cordialement.

19jerway-test-janvier-2017.csv (11.51 Ko)
Le 11/07/2017 à 14:32

Salut à tous,

Thev --> Je n'ai pas compris ton code du tout mais je n'arrive pas à faire tourner la macro ...

MFerrand --> En remplaçant la dernière ligne comme mentionné, j'ai effectivement deux lignes qui restent avec les bons chiffres mais je devrais en avoir plus. C'est ma faute, j'ai tronqué l'excel d'exemples mais en fait les numéros des stations se répètent à intervalles réguliers (toutes les 15/20 lignes environ).

Est-ce qu'il ne faudrait pas que je change la partie for i = 0 to Ubound ... pour que ça continue même après les avoir trouvé une première fois ? (C'est assez obscure vu que je n'y connais rien mais j'essaie de déchiffrer)

Est-ce que tu pourrais me détailler les fonctions que tu as utilisé (pour que je puisse comprendre un peu de VBA) ?

Je vous remercie,

Jerway

Le 11/07/2017 à 22:11

Bonsoir,

Jerway a écrit :

Thev --> Je n'ai pas compris ton code du tout mais je n'arrive pas à faire tourner la macro ...

Effectivement mon code est erronné car je vous ai répondu trop vite.

ci-dessous nouveau code plus paramétrable avec commentaires :

Sub effacer()
    Dim ligne As Range, lignes_à_supprimer As Range
    Dim no_lignes_à_supprimer(), no_ligne As Long
    Dim i As Integer
    'tableau des numéros de ligne à conserver
    no_lignes_à_conserver = Array(7149, 7481)

    '// balayage des lignes utilisées de la feuille active
    For Each ligne In ActiveSheet.UsedRange.Rows
        'numéro de la ligne en cours
        no_ligne = ligne.Row
        'si le numéro de ligne n'est pas trouvé dans le tableau des numéros de ligne à conserver
        'on stocke la ligne complète dans la plage des lignes à supprimer
        On Error Resume Next
        i = 0: i = Application.Match(no_ligne, no_lignes_à_conserver, 0) 'recherche numéro ligne dans tableau lignes à conserver
        If i = 0 Then
            If Not lignes_à_supprimer Is Nothing Then Set lignes_à_supprimer = Union(lignes_à_supprimer, ligne.EntireRow) _
            Else Set lignes_à_supprimer = ligne.EntireRow
        End If
    Next ligne

    '// suppression plage lignes_à_supprimer
    lignes_à_supprimer.Delete

End Sub
Le 12/07/2017 à 09:38

Bonjour, Salut Thev !

en fait les numéros des stations se répètent à intervalles réguliers

En effet, tu nous induit en erreur au départ ! Dans ces conditions, la méthode : récupérer ce qu'on garde, tout effacer, remettre ce qu'on a préservé pourrait donner ceci :

Sub Test()
    Dim tbl(), sta, k%, j%, n&, i&, s&
    sta = Array(7149, 7481)
    With Worksheets(1)
        k = .Cells(1, .Columns.Count).End(xlToLeft).Column
        n = .Cells(.Rows.Count, 1).End(xlUp).Row
        For i = 2 To n
            For j = 0 To UBound(sta)
                If .Cells(i, 1) = sta(j) Then
                    s = s + 1: ReDim Preserve tbl(s)
                    tbl(s) = .Cells(j, 1).Resize(, k).Value
                End If
            Next j
        Next i
        .UsedRange.Offset(1).ClearContents
        For i = 1 To s
            .Cells(i + 1, 1).Resize(, k).Value = tbl(i)
        Next i
    End With
End Sub

Cordialement.

Le 12/07/2017 à 11:24

Bonjour Thev,

Merci de ton temps.

J'ai comprends il me semble pourquoi je me retrouve avec les résultats des lignes no 7149 et 7481.

Mais en fait je voudrais conserver les lignes dont la première cellule possède cette valeur (celles qui se répètent à intervalles réguliers). Est-ce qu'il est possible de remplacer

'tableau des numéros de ligne à conserver
   no_lignes_à_conserver = Array(7149, 7481)

Par quelque chose comme

no_lignes_à_conserver = Array (Si contenu_cellule (1,k)= 7149 alors conserver no_ligne, Si contenu_cellule (1,k)= 7481) alors conserver no_ligne

Je ne sais pas s'il y a une fonction qui peut le faire directement.

Merci en tout cas pour les commentaires, ça m'aide grandement.

MFerrand, la macro me retourne une erreur d'exécution, (1004).

J'ai un peu plus de mal à comprendre celle-là

Le 12/07/2017 à 11:39

Rectification incomplète. Désolé !

                    tbl(s) = .Cells(i, 1).Resize(, k).Value

Remplacer j par i sur cette ligne.

Cordialement.

Le 12/07/2017 à 12:11

Bonjour Jerway,

Suite à ta précision, essayer ce code

Sub effacer()
    Dim ligne As Range, lignes_à_supprimer As Range
    Dim valeurs_à_conserver(), valeur As Variant
    Dim i As Integer
    'tableau des valeurs à conserver
    valeurs_à_conserver = Array(7149, 7481)

    '// balayage des lignes utilisées de la feuille active
    For Each ligne In ActiveSheet.UsedRange.Rows
        'valeur de la colonne 1 de la ligne en cours
        valeur = ligne.Columns(1).Value
        'si la valeur de la colonne 1 n'est pas trouvée dans le tableau des valeurs à conserver
        'on stocke la ligne complète dans la plage des lignes à supprimer
        On Error Resume Next
        i = 0: i = Application.Match(valeur, valeurs_à_conserver, 0) 'recherche numéro ligne dans tableau lignes à conserver
        If i = 0 Then
            If Not lignes_à_supprimer Is Nothing Then Set lignes_à_supprimer = Union(lignes_à_supprimer, ligne.EntireRow) _
            Else Set lignes_à_supprimer = ligne.EntireRow
        End If
    Next ligne

    '// suppression plage lignes_à_supprimer
    lignes_à_supprimer.Delete

End Sub
Le 13/07/2017 à 23:27

Un grand merci à tous les deux.

Vos deux solutions fonctionnent parfaitement et donnent le même résultat.

À très bientôt,

Jerway

Rechercher des sujets similaires à "macro suppression lignes sauf exceptions"