Supprimer plusieurs lignes VBA

[cheikh]

Bonjour,
je me suis inspiré de macros que j'ai trouvé sur le forum pour ensuite les adaptés à mon besoin et ça marchait bien.
Après importation de mes données, je fais deux actions:

• Supprimer les lignes donc le numero sur colonne C commence pas par 30;
• Supprimer les lignes avec valeurs opposées sur colonne M

Avec une centaine de lignes c'était nickel, mais maintenant avec plus de 35000 ligne ça peut prendre plus de 6min.
Avez des solutions pour optimiser le temps de traitement ?
Merci

Sub SuppLigne()
Dim c, Zone As Range
With Sheets("Base").Columns(3)
    Set c = .Find("20*", , xlValues, xlWhole, , , False)
    If Not c Is Nothing Then
        Do
            c.EntireRow.Delete
            Set c = .FindNext
        Loop While Not c Is Nothing
    End If
End With
End Sub
'--------------------   ----------------------------'
Sub SupprLigne2()
Dim Zone As Range, c As Range, Oppos As Range
With Sheets("Base")
Set Zone = .Range("M2:M" & Range("M65536").End(xlUp).Row)
    For Each c In Zone
        Set Oppos = Zone.Find(What:=-c, After:=c, LookIn:=xlValues, Lookat:=xlWhole)
        If Not Oppos Is Nothing Then Oppos = "": c = ""
    Next c
End With
On Error Resume Next
Zone.SpecialCells(xlCellTypeBlanks).EntireRow.Delete shift:=xlShiftUp
End Sub

 

[Dranreb]

Re : Supprimer plusieurs lignes VBA

Bonjour.
Peut être à l'aide des fonctions suivantes :

Function ColLignesOùRelat(ByVal CelDéb As Range, ByVal ColQuoi, ByVal Opé As String, ByVal Valeur) As Range
Rem. ——— Cellules partant de CelDéb dans sa colonne où la colonne ColQuoi est en relation Opé avec Valeur.
Set ColLignesOùRelat = Intersect(LignesOùRelat(CelDéb, ColQuoi, Opé, Valeur), CelDéb.EntireColumn)
End Function

Function LignesOùRelat(ByVal LigneDéb As Range, ByVal ColQuoi, ByVal Opé As String, ByVal Valeur) As Range
Rem. ——— Lignes entières partant de LigneDéb où la colonne ColQuoi est en relation Opé avec une Valeur.
If Not IsNumeric(ColQuoi) Then ColQuoi = LigneDéb.Worksheet.Columns(ColQuoi).Column
If VarType(Valeur) = vbString Then Valeur = """" & Replace(Valeur, _
   """", """""") & """" Else Valeur = Trim$(Str$(Valeur))
Set LignesOùRelat = LignesOùCondR1C1(LigneDéb, CondR1C1:="RC" & ColQuoi & Opé & Valeur)
End Function

Function ColLignesOùCondR1C1(ByVal CelDéb As Range, ByVal CondR1C1 As String) As Range
Rem. ——— Cellules partant de CélDéb dans sa colonne dont les lignes vérifient une condition R1C1 CondR1C1.
Set ColLignesOùCondR1C1 = Intersect(LignesOùCondR1C1(CelDéb, CondR1C1), CelDéb.EntireColumn)
End Function

Function LignesOùCondR1C1(ByVal LigneDéb As Range, ByVal CondR1C1 As String) As Range
Rem. ——— Lignes entières partant de LigneDéb qui vérifient une condition R1C1 CondR1C1.
Dim Lignes As Range, ColTrv As Range
With LigneDéb.Worksheet.UsedRange
   Set Lignes = LigneDéb.EntireRow.Resize(.Rows.Count + .Row - LigneDéb.Row)
   Set ColTrv = Intersect(.Columns(.Columns.Count + 1), Lignes): End With
ColTrv.FormulaR1C1 = "=1/(" & CondR1C1 & ")"
On Error Resume Next
Set LignesOùCondR1C1 = ColTrv.SpecialCells(xlCellTypeFormulas, 1).EntireRow
ColTrv.Delete xlShiftToLeft
End Function

À tester alors :

LignesOùCondR1C1(Sheets("Base").Rows(1), "LEFT(RC3,2)=""20""").Delete
ColLignesOùCondR1C1(Sheets("Base").[M2], "MATCH(-RC13,R[1]C13:R[4999]C13,0)").ClearContents

 

[cheikh]

Re : Supprimer plusieurs lignes VBA

Bonjour Dranreb,