Suppression lignes selon valeur cellule Résolu

Question

Bonjour,

J'ai essayé de saisir des lignes VBA pour supprimer un nombre de ligne (6 ou 7 en fonction des données) selon une valeur trouvée dans la colonne A ("Noé v2017") qui revient en boucle. Je ne sais pas faire de boucle malgré mes différentes recherches donc j'ai trouvé l'astuce d'utiliser la touche F4 après savoir lancé ma macro afin qu'elle se répète en boucle  (je sais ce n'est pas ce qu'il faut faire mais en attendant mieux...). Est-il possible de m'aider à créer cette boucle.

Sub Supp_Lignes_Noe()
'
'
    'Range("A1").Select
    Columns("A:A").Select
    'ActiveCell.Columns("A:A").EntireColumn.Select
    Selection.Find(What:="Noé v2017", After:=ActiveCell).Activate
    ActiveCell.Offset(0, 0).Range("1:7").EntireRow.Select
    Selection.Delete Shift:=xlUp
    'Selection.ClearContents
End Sub

Par la suite, si c'est possible, j'aimerai pouvoir effectuer la même manipulation en entrant dans une boite de dialogue le nom de ma recherche ("Noé v2017" ==>" Noé v2018"...) et dans une autre boite de dialogue le nombre de ligne à supprimer (5, 6 ou 7 selon mon fichier). En attendant, je modifie manuellement cette macro selon mes besoins.

Donc pour récapituler, il doit trouver le texte "Noé v201..." et à partir de cette cellule, supprimer un nombre de ligne x.
L'éditeur de macro ne permet pas cette manipulation.
Je vous remercie de bien vouloir m'aider.
Dans cette attente, je continue mes recherches
Cordialement
Evelyne

jordane45 · Answer

Bonjour

Function FindAll(ByVal sText As String, ByRef oRange As Range, ByRef arMatches() As String) As Boolean
' --------------------------------------------------------------------------------------------------------------
' FindAll - To find all instances of the1 given string and return the row numbers.
' If there are not any matches the function will return false
' --------------------------------------------------------------------------------------------------------------
On Error GoTo Err_Trap
Dim rFnd As Range ' Range Object
Dim iArr As Integer ' Counter for Array
Dim rFirstAddress ' Address of the First Find
' -----------------
' Clear the Array
' -----------------
Erase arMatches
Set rFnd = oRange.Find(what:=sText, LookIn:=xlValues, lookAt:=xlPart)

If Not rFnd Is Nothing Then
   rFirstAddress = rFnd.Address
   Do Until rFnd Is Nothing
      iArr = iArr + 1
      ReDim Preserve arMatches(iArr)
      arMatches(iArr) = rFnd.Row 'rFnd.Address pour adresse complete ' rFnd.Row Pour N° de ligne
      Set rFnd = oRange.FindNext(rFnd)
      If rFnd.Address = rFirstAddress Then Exit Do ' Do not allow wrapped search
   Loop
   FindAll = True
Else
' ----------------------
' No Value is Found
' ----------------------
   FindAll = False
End If
' -----------------------
' Error Handling
' -----------------------
Err_Trap:
If Err <> 0 Then
   MsgBox Err.Number & " " & Err.Description, vbInformation, "Find All"
   Err.Clear
   FindAll = False
   Exit Function
End If
End Function

Sub deleteByValue()
    Dim arMatches() As String
    Dim valcherch As String
    Dim Sh As Worksheet
    Dim rng As Range
    
    Set Sh = ThisWorkbook.Sheets("Feuil1")
    Set rng = Sh.Range("A1:A100")
    
    valcherch = "Noé v2017"
    
    bFound = FindAll(valcherch, rng, arMatches())
    If bFound = True Then
      nbElemTrouve = UBound(arMatches)
      For i = 1 To nbElemTrouve
         Debug.Print (arMatches(i))
         'ici tu peux mettre le code de suppression
         '...
         
      Next
    End If
End Sub

ThauTheme · Answer

Bonjour Evelyne, bonjour le forum,

Peut-être comme ça (nom de l'onglet à adapter) :
Sub Macro1()
Dim O As Worksheet 'déclare la variable O (Onglet)
Dim DL As Integer 'déclare la variable DL (Dernière Ligne)
Dim I As Integer 'déclare la variable I (Incrément)
Dim J As Integer 'déclare la variable J (incrément)
Dim BET As Variant 'déclare la variable BET (Boîte d'Entrée Texte)
Dim BEL As Integer 'déclare la variable BEL (Boîte d'Entrée Ligne)

Application.ScreenUpdating = False 'masque les raffraîchissements d'écran
Set O = Worksheets("Feuil1") 'définit l'onglet O (à adapter à ton cas)
DL = O.Cells(Application.Rows.Count, "A").End(xlUp).Row 'définit la dernière ligne éditée DL de la colonne A de l'onglet O
BET = Application.InputBox("Taper le texte à rechercher.", "RECHERCHE", Type:=2) 'définit la boîte d'entrée BET qui va définir le texte de la recherche
If BET = False Or BET = "" Then Exit Sub 'si bouton [Annuler] ou non renseignée, sort de la procédure
BEL = Application.InputBox("Supprimer combien de lignes", "SUPRESSION", Type:=1) 'définit la boîte d'entrée BEL qui va définir le nombre de lignes à supprimer
If BEL = False Or BEL = 0 Or BEL > Application.Rows.Count Then Exit Sub 'si bouton [Annuler] ou non renseignée ou nombre trop grand, sort de la procédure
J = 1 'initialise la variable J
For I = DL To 1 Step -1 'boucle 1 : inversée des lignes DL à la ligne 1 en remontant
    If O.Cells(I, "A").Value = BET Then 'condition : si la cellule en colonne A de la boucle vaut BET
        O.Rows(I).Delete 'supprime la ligne
        J = J + 1 'incrémente J
        If J > BEL Then Exit Sub 'si J est supérieur à BEL, sort de la procédure
    End If 'fin de la condition
Next I 'prochaine ligne de la boucle 1
End Sub 
 
[Édition]
Bonjour jordane, nos post se sont croisés...

ThauTheme · Answer

Re,

Ça ne pouvait pas marcher !... Je navet (si, si, dans ce cas on peut...) pas vu les choses comme ça. Rien ne vaut un fichier exemple !
Le code modifié. Pour l'instant il ne fait que sélectionner. Teste le et s'il convient, remplace la dernière ligne : PL.Select par PL.Delete.
Le code :

Sub Macro1()
Dim O As Worksheet 'déclare la variable O (Onglet)
Dim DL As Integer 'déclare la variable DL (Dernière Ligne)
Dim TV As Variant 'déclare la variable TV (Tableau des valeurs)
Dim PL As Range 'déclare la variable PL
Dim I As Integer 'déclare la variable I (Incrément)
Dim BET As Variant 'déclare la variable BET (Boîte d'Entrée Texte)
Dim BEL As Integer 'déclare la variable BEL (Boîte d'Entrée Ligne)
Dim LD As Long 'déclare la variable LD (Ligne de Début)
Dim LF As Long 'déclare la variable LF (Ligne de Fin)

Set O = Worksheets("Feuil1") 'définit l'onglet O (à adapter à ton cas)
DL = O.Cells(Application.Rows.Count, "A").End(xlUp).Row 'définit la dernière ligne éditée DL de la colonne A de l'onglet O
TV = O.Range("A1:A" & DL) 'définit le tableau des valeurs TV
Set PL = O.Range("A1") 'initialise la plage PL
BET = Application.InputBox("Taper le début du texte à rechercher.", "RECHERCHE", Type:=2) 'définit la boîte d'entrée BET qui va définir le texte de la recherche
If BET = False Or BET = "" Then Exit Sub 'si bouton [Annuler] ou non renseignée, sort de la procédure
For I = DL To 1 Step -1 'boucle inversée sur toutes les lignes I de la dernière DL à la première
    If UCase(TV(I, 1)) Like UCase(BET) & "*" Then 'si BET (convertie en majuscule) correspond au début du texte recherche (en majuscule aussi)
        LD = I 'définit la ligne de début LD
        'définit la ligne de fin LF (DL si LD = DL, sinon la première ligne, après la ligne de début LD, contenant le texte "Chèque Accueil"
        LF = IIf(LD = DL, I, O.Columns(1).Find("Chèque Accueil", O.Cells(LD, "A"), xlValues, xlWhole).Row)
        'définit la plage PL (les ligne de LD a LF ai PL ne contient qu'une seule cellule, sinon l'union de la plage PL et des ligne LD à LF
        Set PL = IIf(PL.Cells.Count = 1, O.Rows(LD & ":" & LF), Application.Union(PL, O.Rows(LD & ":" & LF)))
    End If 'fin de la condition
Next I 'prochaine ligne de la boucle
PL.Select 'ligne à remplacer par [PL.Delete] quand les tests sont concluants
End Sub

Suppression lignes selon valeur cellule

3 réponses

Discussions similaires

Newsletters