Menu

Suppression lignes selon valeur cellule [Résolu]

Messages postés
72
Date d'inscription
vendredi 6 juillet 2007
Dernière intervention
25 octobre 2018
-
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
Afficher la suite 

Votre réponse

3 réponses

Meilleure réponse
Messages postés
24534
Date d'inscription
mercredi 22 octobre 2003
Statut
Modérateur
Dernière intervention
15 février 2019
1841
1
Merci
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


Dire « Merci » 1

Heureux de vous avoir aidé ! Vous nous appréciez ? Donnez votre avis sur nous ! Evaluez CommentCaMarche

CCM 58162 internautes nous ont dit merci ce mois-ci

jordane45
Messages postés
24534
Date d'inscription
mercredi 22 octobre 2003
Statut
Modérateur
Dernière intervention
15 février 2019
1841 -
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
72
Date d'inscription
vendredi 6 juillet 2007
Dernière intervention
25 octobre 2018
-
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
24534
Date d'inscription
mercredi 22 octobre 2003
Statut
Modérateur
Dernière intervention
15 février 2019
1841 -
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

Commenter la réponse de jordane45
Messages postés
4463
Date d'inscription
mardi 21 octobre 2014
Dernière intervention
14 février 2019
227
1
Merci
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...

À plus,
ThauTheme

Dire « Merci » 1

Heureux de vous avoir aidé ! Vous nous appréciez ? Donnez votre avis sur nous ! Evaluez CommentCaMarche

CCM 58162 internautes nous ont dit merci ce mois-ci

Evedll
Messages postés
72
Date d'inscription
vendredi 6 juillet 2007
Dernière intervention
25 octobre 2018
-
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
72
Date d'inscription
vendredi 6 juillet 2007
Dernière intervention
25 octobre 2018
-
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
Commenter la réponse de ThauTheme
Messages postés
4463
Date d'inscription
mardi 21 octobre 2014
Dernière intervention
14 février 2019
227
0
Merci
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


À plus,
ThauTheme
Evedll
Messages postés
72
Date d'inscription
vendredi 6 juillet 2007
Dernière intervention
25 octobre 2018
-
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
Commenter la réponse de ThauTheme