Suppression de ligne avec condition

[Florian53]

Bonjour à tous,

Je souhaite supprimer des lignes sur un classeur qui contient plus de 350 000 lignes,

Les conditions sont :

- Si dans la ligne x de la colonne "A" ne commence pas par ( YTD ACT, B ou Réel ) alors supprimer la ligne.

J'ai effectué ce code qui fonctionne mais celui ci est très long à s’exécuter, avez vous une astuce afin d'accélérer le code?

Sub SupprLigne()
Dim i As Long
Dim DerLigne As Long
Dim crit1, crit2, crit3 As String

With Sheets("BDD").Activate
DerLigne = Range("A" & Rows.Count).End(xlUp).Row
crit1 = "YTD ACT*"
cri2 = "Reel*"
crit3 = "B*"
For i = DerLigne To 1 Step -1
    If Cells(i, 1).Value <> crit1 Or Cells(i, 1).Value <> crit2 Or Cells(i, 1).Value <> crit3 Then
    Cells(i, 1).EntireRow.Delete
    End If
Next i
End With
End Sub

Merci à vous

 

[vgendron]

Hello

Essaie avec ce code dans lequel
1) j'ai juste ajouté le screenupdating en début et fin de macro
2) et il me semble que le test <>crit1 or <>Crit2... n'est pas bon
il faut plutot <>Crit1 AND <> Crit2..
et j'ai corrigé une erreur de syntaxe sur le Critère2:
Crit2="Rell*" tu avais oublié le T de Crit...

3) de plus. pas sur que le caractère "*" soit compris par VBA comme tu le souhaites

il faudrait que tu postes un fichier exemple.. allégé évidemment.. juste quelques lignes qui permettent de traiter tous les cas pouvant arriver.
et il y a surement une possibilité de traitement "immédiat" avec des tableaux..
mais la encore. sans fichier, difficile de te proposer tout de suite.

Sub SupprLigne()
Dim i As Long
Dim DerLigne As Long
Dim crit1, crit2, crit3 As String

Application.ScreenUpdating = False
With Sheets("BDD")
    DerLigne = .Range("A" & .Rows.Count).End(xlUp).Row
    crit1 = "YTD ACT*"
    crit2 = "Reel*"
    crit3 = "B*"
    For i = DerLigne To 1 Step -1
        If .Cells(i, 1).Value <> crit1 And .Cells(i, 1).Value <> crit2 And .Cells(i, 1).Value <> crit3 Then
            .Cells(i, 1).EntireRow.Delete
        End If
    Next i
End With
Application.ScreenUpdating = True
End Sub

 

[job75]

Bonjour Florian53, vgendron,

Sub SupprLigne()
Application.ScreenUpdating = False
With Sheets("BDD").UsedRange
  If .Parent.FilterMode Then .Parent.ShowAllData 'si la feuille est filtrée
  .Columns(1).EntireColumn.Insert
  .Columns(0) = "=1/OR(LEFT(RC[1],7)=""YTD ACT"",LEFT(RC[1])=""B"",LEFT(RC[1],4)=""Reel"")"
  .Columns(0) = .Columns(0).Value 'supprime les formules
  .Columns(0).Resize(, .Columns.Count + 1).Sort .Columns(0), xlAscending, Header:=xlYes 'tri (avec en-têtes) pour accélérer
  On Error Resume Next 'si aucune valeur d'erreur
  .Columns(0).Offset(1).SpecialCells(xlCellTypeConstants, 16).EntireRow.Delete
  .Columns(0).EntireColumn.Delete
End With
End Sub

Faudrait savoir une fois pour toutes si c'est "Reel" ou "Réel" !!!

Et c'est la nième fois que je propose un code de ce style, raz le bol.

A+

 

[vgendron]

Hello Job ! j'ai l'impression que notre ami n'en est pas à son premier post sur le sujet :-D

en attendant, je me suis amusé avec des tablos..ce qui donne

Sub SupprLigne()
'à partir de la feuille BDD, ne récupère QUE les lignes qui contiennent un des critères
'et les colle dans la feuille BDD2.. qui doit donc exister dans le fichier
Dim i,j,k As Long

Dim crit1, crit2, crit3 As String
Dim tablo() As Variant
Dim tablo2() As Variant

Application.ScreenUpdating = False
crit1 = "YTD ACT*"
crit2 = "Reel*"
crit3 = "B*"
   
With Sheets("BDD")
    tablo = .Range("A1").CurrentRegion.Value
    For i = LBound(tablo, 1) To UBound(tablo, 1)
        If Not (tablo(i, 1) Like crit1 Or tablo(i, 1) Like crit2 Or tablo(i, 1) Like crit3) Then
            For j = LBound(tablo, 2) To UBound(tablo, 2)
                tablo(i, j) = ""
            Next j
        Else: nb = nb + 1
        End If
    Next i
    ReDim tablo2(1 To nb, 1 To UBound(tablo, 2))
    k = 1
    For i = LBound(tablo, 1) To UBound(tablo, 1)
        If tablo(i, 1) <> "" Then
            For j = LBound(tablo, 2) To UBound(tablo, 2)
                tablo2(k, j) = tablo(i, j)
            Next j
            k = k + 1
        End If
    Next i
   
    Sheets("BDD2").Range("A1").Resize(UBound(tablo2, 1), UBound(tablo2, 2)) = tablo2
End With
Application.ScreenUpdating = True
End Sub

 

[job75]

Re,

Testé sur 350 000 lignes et une seule colonne (fichier de 3,1 Mo), une ligne sur deux supprimée :

- macro du post #3 => 2,5 secondes

- macro du post #4 => 0,91 seconde.

Mais avec 20 colonnes (fichier de 47,5 Mo) :

- macro du post #3 => 7,3 secondes

- macro du post #4 => 32 secondes.

A+

 

[Florian53]

Bonsoir, merci à vous car les 2 solutions fonctionne. j'utilise du coup la macro de Job car je dispose de plus de 20 colonnes.

Par contre la mise en forme des colonnes est supprimée, est ce possible d'avoir la meme chose en gardant la mise en forme.

Merci et vs

 

[Florian53]

Non dsl, ne prenait pas en considération ma demande c'était une mauvaise manip de ma part qui a fait enlever la mise en forme.

Encore merci