Suppression lignes selon valeur cellule

Résolu/Fermé

Valeur

Evedll Messages postés 74 Date d'inscription vendredi 6 juillet 2007 Statut Membre Dernière intervention 26 septembre 2023 - Modifié le 22 oct. 2018 à 10:36
Evedll Messages postés 74 Date d'inscription vendredi 6 juillet 2007 Statut Membre Dernière intervention 26 septembre 2023 - 22 oct. 2018 à 23:08

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

A voir également:

Vba supprimer des lignes en fonction d'une valeur
Supprimer une page word - Guide
Supprimer compte instagram - Guide
Fonction si et - Guide
Supprimer edge - Guide
Supprimer bing - Guide

3 réponses

Réponse 1 / 3

jordane45 Messages postés 38144 Date d'inscription mercredi 22 octobre 2003 Statut Modérateur Dernière intervention 21 avril 2024 4 650
22 oct. 2018 à 09:24

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

jordane45 Messages postés 38144 Date d'inscription mercredi 22 octobre 2003 Statut Modérateur Dernière intervention 21 avril 2024 4 650
22 oct. 2018 à 10:35

NB : Prend le code de ThauTheme .
Je viens de voir que le miens pourrait te causer des difficultés....
En effet, il faudra faire la boucle en partant de la fin (comme dans l'exemple de ThauTheme ) cas sinon les Numéros de lignes ne seront plus les bons au fur et à mesure que tu les supprimera )

Evedll Messages postés 74 Date d'inscription vendredi 6 juillet 2007 Statut Membre Dernière intervention 26 septembre 2023
22 oct. 2018 à 18:27

Bonjour Jordane,
Oui j'ai essayé ce matin avec un peu de mal. Je vais donc voir celui de ThauTheme.
Cependant, je te remercie beaucoup de m'aider car je n'ai jamais appris et c'est difficile seule mais je progresse avec l'aide de vous tous.
Cordialement
Evelyne

jordane45 Messages postés 38144 Date d'inscription mercredi 22 octobre 2003 Statut Modérateur Dernière intervention 21 avril 2024 4 650
22 oct. 2018 à 20:15

Voila le code modifié et fonctionnel...

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
    Application.ScreenUpdating = False
    Set Sh = ThisWorkbook.Sheets("Feuil1")
    Set rng = Sh.Range("A1:A3000")
    
    valcherch = "Noé v2017"
    
    bFound = FindAll(valcherch, rng, arMatches())
    If bFound = True Then
      nbElemTrouve = UBound(arMatches)
      For i = nbElemTrouve To 1 Step -1
         Debug.Print (arMatches(i))
         'ici tu peux mettre le code de suppression
         '...
         Rows(arMatches(i)).Delete
         
      Next
    End If
    Application.ScreenUpdating = True
End Sub

Réponse 2 / 3

ThauTheme Messages postés 1442 Date d'inscription mardi 21 octobre 2014 Statut Membre Dernière intervention 29 juillet 2022 160
Modifié le 22 oct. 2018 à 09:44

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...

Evedll Messages postés 74 Date d'inscription vendredi 6 juillet 2007 Statut Membre Dernière intervention 26 septembre 2023
22 oct. 2018 à 18:32

Bonjour ThauTheme,
Merci de ton aide.
Je vais tester et analyser pour comprendre et te donnerai mon résultat dès que possible.
J'ai vu que tu as bien expliqué chaque ligne et ça devrait m'aider pas mal.
A bientôt
Evelyne

Evedll Messages postés 74 Date d'inscription vendredi 6 juillet 2007 Statut Membre Dernière intervention 26 septembre 2023
22 oct. 2018 à 19:48

Hello,
J'ai essayé tes lignes de commandes. Je vois bien apparaitre les boites de dialogues dans lesquelles je saisis mes données. Par contre, cela ne supprime qu'une ligne (avec la valeur Noé...) sans les 6 lignes qui suivent cette donnée et pas dans la totalité de ma feuille. Voici le lien de mon fichier. J'ai modifié les coordonnées pour la protection des données mais j'ai laissé le plus important. Pour que tu puisses voir ce qu'il faut supprimer, j'ai mis les lignes en couleur. Ce fichier est un des plus petits que j'ai. J'ai essayé de voir où était le problème mais je ne vois pas. Merci si tu peux m'aider.

https://we.tl/t-QvBe1r9C99

Bien cordialement
Evelyne

Réponse 3 / 3

ThauTheme Messages postés 1442 Date d'inscription mardi 21 octobre 2014 Statut Membre Dernière intervention 29 juillet 2022 160
Modifié le 22 oct. 2018 à 20:34

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

Evedll Messages postés 74 Date d'inscription vendredi 6 juillet 2007 Statut Membre Dernière intervention 26 septembre 2023
22 oct. 2018 à 23:08

SUPER !!!!!

Alors là, ça me coupe le souffle ! ça fait des jours que je cherche à comprendre comment pouvoir faire et même avec ce que tu m'as donné en début, je n'ai pas su corriger moi même. Et toi, en une demi heure c'est fait.
UN GRAND MERCI.
J'ai encore beaucoup à travailler sur ces fichiers et j'en ai beaucoup, et pour certains bien plus grand que celui là et j'essaie de trouver seule au maximum mais je galère. Sans formation ou sans aide, c'est très compliqué.
C'est agréable de se savoir soutenue.
Cordialement
Evelyne

Discussions similaires

Ajouter des lignes en fonction de la valeur d'une cellule.

si plage contient du texte alors ....

Copier une ligne en fonction de la valeur d'une cellule

regrouper des cellules identique d'une colonne

Copier une ligne en fonction d'une cellule

Afficher le numéro de ligne de la cellule

Discussions similaires

Newsletters