Supprimer des lignes dont la valeur en colone A se termine par "_ENR"

Bonjour à toutes et à tous,

J'extrais un fichier EXCEL toutes les semaines contenant 47000 lignes mais il y a des lignes erronés. Je dois donc les supprimés manuellement toutes les semaines.

Je débute VBA et je ne suis pas un pro d'EXCEL (Désolé) et je voudrais pouvoir créé une macro que je pourrai lancer chaque semaine sur mon extraction de la semaine pour pouvoir supprimer les lignes dont la valeur en colonne A se termine par une des valeurs suivantes :

_ENR

_SCB

_BR1

_TO1

_IN1

_LO1

_RU1

_ST1

_CA1

_SCI

_LM1

_PA1

_CH1

_ZAM

Exemple de valeur dont je veux supprimer la ligne "PC2_20170421_ENR".

Je joints un exemple de fichier.

Autre info : je n'ai pas mis la totalité du fichier pour des raisons de donnée personnel mais le fichier est lourd et du coup pas très réactif.

J'ai trouvé des sujets qui parle de problème proche mais je n'ai pas réussi à les adapter à mon problème.

Merci par avance pour votre aide et j'espère que mon explication est claire.

Bonjour,

Une proposition :

Sub SuppressionConditionnelle()

'Déclaration des variables
Dim Lig As Long, LigMax As Long, Listing As Variant, Code As Integer

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With Sheets("ListingSuppr")
    'Chargement des codes dans une variable tableau
    Listing = .Range("A1:A" & .Range("A" & Rows.Count).End(xlUp).Row)
End With
With Sheets("Feuil1")
    LigMax = .Range("A" & Rows.Count).End(xlUp).Row
    For Lig = LigMax To 1 Step -1 'Boucle sur les lignes, en partant de la dernière
        For Code = LBound(Listing) To UBound(Listing) 'Boucle sur les codes
            If .Range("A" & Lig) Like "*" & Listing(Code, 1) Then .Rows(Lig).Delete 'Si correspondance, supprimer la ligne
        Next Code
    Next Lig
    MsgBox LigMax - .Range("A" & Rows.Count).End(xlUp).Row & " lignes ont été supprimées."
End With
Application.Calculation = xlCalculationAutomatic

End Sub

Le fichier :

bonjour,

une proposition

edit : Salut Pedro22

Sub aargh()
    Dim td()
    With Sheets("feuil1")
        dl = .Cells(Rows.Count, 1).End(xlUp).Row
        dc = .Cells(1, Columns.Count).End(xlToLeft).Column
        term = Split("_ENR,_SCB,_BR1,_TO1,_IN1,_LO1,_RU1,_ST1,_CA1,_SCI,_LM1,_PA1,_CH1,_ZAM", ",")
        ReDim td(1 To dl, 1 To 1)
        For i = 1 To dl
            s = Right(.Cells(i, 1), 4)
            For j = LBound(term) To UBound(term)
                If s = term(j) Then td(i, 1) = "X": Exit For
            Next j
        Next i
        .Cells(1, dc + 1).Resize(dl, 1) = td
        .Range("A1").Resize(dl, dc + 1).Sort key1:=.Cells(1, dc + 1), order1:=xlAscending, Header:=xlYes
        .Cells(1, dc + 1).Resize(dl, 1).SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete shift:=xlUp
    End With
End Sub

Merci beaucoup PEDRO22 et h2so4.

La macro fonctionne.

Salut Takiloum,

Salut Pedro, h2sO4,

fort semblable, évidemment, mais, ici, il te suffit de :

• d'abord, ouvrir ton fichier contenant l'extract' (! pas d'autres fichiers ouverts !) ;
• ouvrir ensuite le fichier 'ExtractTAKILOUM.xlsm' qui se charge de détecter ton extract' et de faire le travail.

Private Sub Workbook_Activate()
'
Dim sWB As Workbook, sWBB As Workbook, tTab, tItem(), lgRow&, iCol%
'
On Error Resume Next
Application.ScreenUpdating = False
'
For Each sWB In Workbooks
    If sWB.Name <> ThisWorkbook.Name Then
        Set sWBB = sWB
        With sWBB
            lgRow = .Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
            iCol = .Sheets(1).Cells(1, Columns.Count).End(xlToLeft).Column
            tTab = .Sheets(1).Range("A1").Resize(lgRow, iCol).Value
            .Close False
        End With
        tItem = Array("_ENR", "_SCB", "_BR1", "_TO1", "_IN1", "_LO1", "_RU1", "_ST1", "_CA1", "_SCI", "_LM1", "_PA1", "_CH1", "_ZAM")
        For x = 2 To UBound(tTab, 1)
            For y = 0 To 13
                If Right(tTab(x, 1), 4) = tItem(y) Then
                    tTab(x, 1) = ""
                    Exit For
                End If
            Next
        Next
        With Worksheets("Extract")
            .Cells.Delete
            .Range("A1").Resize(lgRow, iCol).Value = tTab
            .Range("A1:A" & lgRow).SpecialCells(xlCellTypeBlanks).EntireRow.Delete shift:=xlUp
            lgRow = .Range("A" & Rows.Count).End(xlUp).Row
            .Range("A1").Resize(lgRow, iCol).Borders.LineStyle = xlContinuous
            .Range("A1").Resize(1, iCol).Interior.ColorIndex = 15
            .Columns.HorizontalAlignment = xlHAlignLeft
            .Columns.AutoFit
        End With
        Exit For
    End If
Next
Application.ScreenUpdating = True
On Error GoTo 0
'
End Sub

A+

Merci curulis57

Pedro, h2sO4 et curulis57 je vais devoir maintenant remettre dans les cours de VBA de "EXCEL-PRATIQUE" pour comprendre vos macro afin pouvoir développer des macro aussi pratique que les vôtres et qui sait, peut-être qu'un jour je pourrai également apporter mon aide à une âme en peine comme moi aujourd'hui.

Encore merci à vous 3.