Bonjour à tous
j'ai trouvé un bug dans ma dernière version alors voila un correctif. Pour info, Thierry a proposé une solution trés rapide que vous trouverez la.
<http://www.excel-downloads.com/html/French/forum/read.php?f=1&i=103479&t=101832>
Cordialement, A+
Sub Supprimer_Lignes()
'définition des variables
Dim Tab_Cells As Variant, Tab_Row() As String, Mem_Row As Long
Dim Cellule_Debut As Range, Cellule_Fin
Dim Deb_Tab As Long, Compteur As Long, Compteur2 As Long, Compteur3 As Long
'désactivation de l'affichage écran pour gagner en rapidité
Application.ScreenUpdating = False
With ActiveSheet
'indiquer ici la plage de test
'si je désire tester les cellules colonnes A et D sur 6000 lignes la plage sera range("A1
6000")
'la ligne suivante définit le début du tableau de valeurs pour test
Set Cellule_Debut = .Range("A1")
'la ligne suivante définit la fin du tableau de valeurs pour test
'la valeur actuelle correspond à la dernière cellule de la colonne D avec possibilité de valeur
Set Cellule_Fin = Range("D" & Range("A1").SpecialCells(xlCellTypeLastCell).Row)
'mémorise la ligne de début du tableau de valeurs
Mem_Row = Cellule_Debut.Row - 1
'passe les valeurs de cellules au tableau de valeurs
Tab_Cells = .Range(Cellule_Debut.Address & ":" & Cellule_Fin.Address).Value
'initialise les compteurs
Compteur = 0
'boucle sur la longueur du tableau
For Compteur2 = LBound(Tab_Cells) To UBound(Tab_Cells)
'indiquer ici la valeur du test et les ou la colonne du tableau, ici 2 car colonnes de test sur A et D
If Tab_Cells(Compteur2, 1) = "PCI Dump" Or Tab_Cells(Compteur2, 4) = "519" Then
Compteur = Compteur + 1
'on redimensionne en conservant les valeurs
ReDim Preserve Tab_Row(1 To Compteur) As String
'indiquer ici la plage à supprimer, laisser de A à IV pour lignes entières
Tab_Row(Compteur) = "A" & (Compteur2 + Mem_Row) & ":" & "IV" & (Compteur2 + Mem_Row)
'on enregistre le numéro de première ligne test ok
End If
Next Compteur2
'on efface les lignes détectées en partant de la fin
For Compteur2 = Compteur To 1 Step -1
.Range(Tab_Row(Compteur2)).Delete Shift:=xlUp
Next Compteur2
End With
End Sub