excel vba Supprimer les lignes jusqu'au critère

Question

Je suis novice dans Excel VBA et je pourrais vraiment vous aider. J'ai essayé de trouver une solution sur le Web, mais je n'ai pas réussi à trouver un problème similaire.

J'essaye de créer une macro qui aidera à supprimer des rangées basées sur certains critères et continuer à supprimer des rangées jusqu'à ce qu'un certain critère soit rencontré.

Par exemple. Dans le tableau ci-dessous, je voudrais supprimer des lignes où Col A = 1 ET Col C = 0, puis continuez à supprimer les lignes ci-dessous cette ligne JUSQU'AU Col A = 1 et Col C <> 0

A | B | C 
-----|-----|----- 
1 | TC | 2 
-----|-----|----- 
2 | TC | 1 
-----|-----|----- 
1 | TC | 0 
-----|-----|----- 
2 | TC | 2 
-----|-----|----- 
3 | TC | 1 
-----|-----|----- 
1 | TC | 2 
-----|-----|----- 
1 | TC | 0 
-----|-----|----- 
1 | TC | 1 
-----|-----|----- 
2 | TC | 0 
-----|-----|----- 
3 | TC | 2 

Ainsi, le résultat final de la macro serait:

A | B | C 
-----|-----|----- 
1 | TC | 2 
-----|-----|----- 
2 | TC | 1 
-----|-----|----- 
1 | TC | 2 
-----|-----|----- 
1 | TC | 1 
-----|-----|----- 
2 | TC | 0 
-----|-----|----- 
3 | TC | 2 

Idéalement, je voudrais en boucle ce nouveau avec suppression de lignes où Col A = 2 et Col C = 0 et la suppression des lignes ci-dessous cette ligne jusqu'à ce que Col A = 2 et Col C <> 0.

Ci-dessous la macro avec laquelle je suis arrivé. Ouvert à toutes les suggestions et désireux d'apprendre.

Sub deleterow() 

Range("C2").Select 
Do Until ActiveCell.Offset(0, -2) = "1" And ActiveCell.Value <> "0" 
If ActiveCell.Value = "0" And ActiveCell.Offset(0, -2) = "1" Then 
Rows(ActiveCell.Row & ":" & Rows.Count).Delete 
End If 
Loop 

End Sub 

Dans l'attente d'entendre de nouveau!

Merci

Answer 1

Votre boucle arrête sur la première ligne, parce que les critères sont respectés. Ainsi, le code ci-dessous passe de la première ligne à la dernière ligne remplie pour rechercher les critères.

Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets(1) 'Set the first worksheet to work 
Dim n As Long, i As Long 
Dim rng As Range, new_rng As Range 

lastrow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row 'lastrow number 
For n = 1 To 2 'Criteria is Col A = 1 To 2 
    For i = 1 To lastrow 'Loop from 1 to last row 
     If ws.Cells(i, 1) = n And ws.Cells(i, 3) = 0 Then 
      If rng Is Nothing Then Set rng = ws.Range("A" & i) 'Set first Range so Union won't give an error 
      Set new_rng = ws.Range("A" & i) 
      Set rng = Union(rng, new_rng) 'create a non contiguous range to delete 
     End If 
    Next i 
Next n 

rng.EntireRow.Delete 

Notez que si la feuille est grande, il n'est pas la méthode optimale. Il existe de meilleurs moyens d'améliorer les performances du code. Une boucle a été utilisée, car c'était la méthode essayée par l'OP.

Une autre façon est de filtrer pour multicritères et de supprimer les lignes affichées.