Macro selection

mcj1997 · 27 Janvier 2012

Bonjour

La macro ci-dessous me permets de sélectionner les lignes qui comportent Ford et Renault. Ma demande je souhaite qu'une fois les lignes colorées, effacer toutes les autre lignes mais garder à chaque fois la ligne sélectionnée + les trois lignes en dessous.

Merci davance

Selection.Interior.ColorIndex = 11
* *Cells.Find(What:="PEUGEOT", After:=ActiveCell, LookIn:=xlFormulas, _
* * * *LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
* * * *MatchCase:=False, SearchFormat:=False).Activate
*
* *Selection.Interior.ColorIndex = 11
* *Cells.Find(What:="FORD", After:=ActiveCell, LookIn:=xlFormulas, _
* * * *LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
* * * *MatchCase:=False, SearchFormat:=False).Activate

End

phlaurent55 · 27 Janvier 2012

Re : Macro selection

Bonjour mcj,

sans voir ton fichier, tu risques d'attendre la réponse adaptée

à+
Philippe

Softmama · 27 Janvier 2012

Re : Macro selection

Bonjour mcj1997, salutations phlaurent55,

Un essai de ce que je pense avoir compris en PJ.

VB:

Sub test()
Dim c As Range, Zone As Range, rMin As Long
rMin = -3
With Feuil1 ' (Adapter le codename de la feuille concernée)
  Set c = Range(Split(.UsedRange.Address, ":")(0)) '1ère cellule de la zone utile
  Do While c.Row <= Split(.UsedRange.Address, "$")(4) 'Pour chaque ligne de la zone utile
    If Intersect(c.EntireRow, .UsedRange).Find("Ford", , xlValues, xlPart) Is Nothing And Intersect(c.EntireRow, .UsedRange).Find("Renault", , xlValues, xlPart) Is Nothing Then 'Si y a ni Ford ni Renault...
    If c.Row - rMin > 3 Then Cells(c.Row, "IV") = 1 'On place 1 en colonne IV si ligne de c est > 3+ rMin
  Else
    rMin = c.Row 'Sinon rMin prend la valeur de la ligne de c
  End If
  Set c = c.Offset(1) 'on passe à la cellule suivante
Loop
On Error Resume Next: Range("IV1").EntireColumn.SpecialCells(xlCellTypeConstants, 1).EntireRow.Delete 'Tous les lignes ayant 1 en colonne IV sont effacées
End Sub

Softmama · 27 Janvier 2012

Re : Macro selection

Re,

J'ai pas tenu compte de la mise en couleur dans mon précédent post. Erreur réparée ici à priori :

VB:

Sub test()
Dim c As Range, rMin As Long, AdrUtile As String
rMin = -3
With Feuil1 ' (Adapter le codename de la feuille concernée)
  AdrUtile = .UsedRange.Address 'Zone utile
  Set c = Range(Split(AdrUtile, ":")(0)) '1ère cellule de la zone utile
  Do While c.Row <= Split(AdrUtile, "$")(4) 'Pour chaque ligne de la zone utile
    If Intersect(c.EntireRow, Range(AdrUtile)).Find("Ford", , xlValues, xlPart) Is Nothing And Intersect(c.EntireRow, Range(AdrUtile)).Find("Renault", , xlValues, xlPart) Is Nothing Then 'Si y a ni Ford ni Renault...
      If c.Row - rMin > 3 Then Cells(c.Row, "IV") = 1 'On place 1 en colonne IV si ligne de c est > 3+ rMin
    Else
      rMin = c.Row 'Sinon rMin prend la valeur de la ligne de c
      Intersect(c.EntireRow, Range(AdrUtile)).Interior.ColorIndex = 11 'colorisation ligne
    End If
    Set c = c.Offset(1) 'on passe à la cellule suivante
  Loop
  On Error Resume Next: .Range("IV1").EntireColumn.SpecialCells(xlCellTypeConstants, 1).EntireRow.Delete 'Tous les lignes ayant 1 en colonne IV sont effacées
End With
End Sub

mcj1997 · 28 Janvier 2012

Re : Macro selection

Softmama à dit:

Re,

J'ai pas tenu compte de la mise en couleur dans mon précédent post. Erreur réparée ici à priori :

VB:

Sub test()
Dim c As Range, rMin As Long, AdrUtile As String
rMin = -3
With Feuil1 ' (Adapter le codename de la feuille concernée)
  AdrUtile = .UsedRange.Address 'Zone utile
  Set c = Range(Split(AdrUtile, ":")(0)) '1ère cellule de la zone utile
  Do While c.Row <= Split(AdrUtile, "$")(4) 'Pour chaque ligne de la zone utile
    If Intersect(c.EntireRow, Range(AdrUtile)).Find("Ford", , xlValues, xlPart) Is Nothing And Intersect(c.EntireRow, Range(AdrUtile)).Find("Renault", , xlValues, xlPart) Is Nothing Then 'Si y a ni Ford ni Renault...
      If c.Row - rMin > 3 Then Cells(c.Row, "IV") = 1 'On place 1 en colonne IV si ligne de c est > 3+ rMin
    Else
      rMin = c.Row 'Sinon rMin prend la valeur de la ligne de c
      Intersect(c.EntireRow, Range(AdrUtile)).Interior.ColorIndex = 11 'colorisation ligne
    End If
    Set c = c.Offset(1) 'on passe à la cellule suivante
  Loop
  On Error Resume Next: .Range("IV1").EntireColumn.SpecialCells(xlCellTypeConstants, 1).EntireRow.Delete 'Tous les lignes ayant 1 en colonne IV sont effacées
End With
End Sub

Bonjour,

Je viens de mettre en PJ un fichier,

Merci d'avance,

Softmama · 28 Janvier 2012

Re : Macro selection

Bonjour,

oui, ben remplace ta macro2 par :

VB:

Sub test()
Dim c As Range, rMin As Long, AdrUtile As String
rMin = -3
With Feuil1 ' (Adapter le codename de la feuille concernée)
 AdrUtile = .UsedRange.Address 'Zone utile
 Set c = Range(Split(AdrUtile, ":")(0)) '1ère cellule de la zone utile
 Do While c.Row <= Split(AdrUtile, "$")(4) 'Pour chaque ligne de la zone utile
   If Intersect(c.EntireRow, Range(AdrUtile)).Find("Ford", , xlValues, xlPart) Is Nothing And Intersect(c.EntireRow, Range(AdrUtile)).Find("Renault", , xlValues, xlPart) Is Nothing And Intersect(c.EntireRow, Range(AdrUtile)).Find("Peugeot", , xlValues, xlPart) Is Nothing Then 'Si y a ni Ford ni Renault ni Peugeot...
     If c.Row - rMin > 3 Then Cells(c.Row, "IV") = 1 'On place 1 en colonne IV si ligne de c est > 3+ rMin
   Else
      rMin = c.Row 'Sinon rMin prend la valeur de la ligne de c
     Intersect(c.EntireRow, Range(AdrUtile)).Interior.ColorIndex = 11 'colorisation ligne
   End If
    Set c = c.Offset(1) 'on passe à la cellule suivante
 Loop
  On Error Resume Next: .Range("IV1").EntireColumn.SpecialCells(xlCellTypeConstants, 1).EntireRow.Delete 'Tous les lignes ayant 1 en colonne IV sont effacées
End With
End Sub

Tu as essayé de le faire ?

mcj1997 · 28 Janvier 2012

Re : Macro selection

Bonsoir,

En partant de mon fichier je souhaite adapter ma macro à mon besoin sans avoir à ajouter 1 en colonne, c'est trop fastidieux car j'ai énormément de lignes.

Il doit bien exister une fonction qui permette de supprimer une ligne qui ne comprend pas tel ou tel mot.

Merci

Softmama · 29 Janvier 2012

Re : Macro selection

mcj1997 à dit:
Il doit bien exister une fonction qui permette de supprimer une ligne qui ne comprend pas tel ou tel mot.

Non, sinon, on te pondrait pas des macros pour le faire...

ROGER2327 · 29 Janvier 2012

Re : Macro selection

Bonjour à tous

... et la ponte continue...

VB:

Sub tata()
Dim i&, j%, n&, l&, c&, um&, m(), a() As Boolean
    m = Array("FORD", "PEUGEOT", "RENAULT") 'réf. à adapter au besoin
    um = UBound(m)
    With Feuil4.[A1] 'première cellule de données
        l = .Row
        c = .Column
        n = .Offset(Rows.Count - .Row, 0).End(xlUp).Row + 3
        ReDim a(1 To n)
        With .Parent
            For i = n To l Step -1
                For j = 0 To um
                    If .Cells(i, c).Value = m(j) Then Exit For
                Next
                If j > um Then a(i) = True Else For j = 1 To 3: a(i + j) = False: Next
            Next
            With Application: .ScreenUpdating = 0: .EnableEvents = 0: .Calculation = -4135: End With
            For i = n To l Step -1
                If a(i) Then .Cells(i, c).EntireRow.Delete
            Next
            With Application: .Calculation = -4105: .EnableEvents = -1: .ScreenUpdating = -1: End With
        End With
    End With
End Sub

ROGER2327
#5414

Mercredi 4 Gueules 139 (Sainte Goule ou Gudule, institutrice - fête Suprême Quarte)
9 Pluviôse An CCXX, 1,5261h - peuplier
2012-W04-7T03:39:45Z

mcj1997 · 29 Janvier 2012

Re : Macro selection

Bonjour,

Merci ROGER qui a bien compris je ne parlais effectivement pas de fonction mais de macro.
Cela fonctionne mais c'est long car j'ai 25000 lignes, serait il possible d'adapter la macro afin d'arrêter la recherche des mots dès lors que les trois (dans l'exemple) sont trouvés pour ainsi raccourcir la durée de recherche.

Aussi le nombre de lignes en dessous chaque nom peut évoluer, est-il possible au lieu d'inscrire dans la macro le nombre de lignes en dessous demander à garder la ligne et toutes les lignes qui y sont rattachées (plan).

Merci d'avance,

mcj1997 · 31 Janvier 2012

Re : Macro selection

Bonjour,

Personne d'inspiré par rapport à mon besoin ?

Merci d'avance,

mcj1997 à dit:
Bonjour,

Merci ROGER qui a bien compris je ne parlais effectivement pas de fonction mais de macro.
Cela fonctionne mais c'est long car j'ai 25000 lignes, serait il possible d'adapter la macro afin d'arrêter la recherche des mots dès lors que les trois (dans l'exemple) sont trouvés pour ainsi raccourcir la durée de recherche.

Aussi le nombre de lignes en dessous chaque nom peut évoluer, est-il possible au lieu d'inscrire dans la macro le nombre de lignes en dessous demander à garder la ligne et toutes les lignes qui y sont rattachées (plan).

Merci d'avance,

Macro selection

mcj1997

XLDnaute Accro

phlaurent55

Nous a quittés en 2020

Softmama

XLDnaute Accro

Pièces jointes

Softmama

XLDnaute Accro

Pièces jointes

mcj1997

XLDnaute Accro

Pièces jointes

Softmama

XLDnaute Accro

mcj1997

XLDnaute Accro

Softmama

XLDnaute Accro

ROGER2327

XLDnaute Barbatruc

mcj1997

XLDnaute Accro

mcj1997

XLDnaute Accro

Discussions similaires

Macro selection

XLDnaute Accro

Nous a quittés en 2020

XLDnaute Accro

Pièces jointes

XLDnaute Accro

Pièces jointes

XLDnaute Accro

Pièces jointes

XLDnaute Accro

XLDnaute Accro

XLDnaute Accro

XLDnaute Barbatruc

XLDnaute Accro

XLDnaute Accro

Discussions similaires

Privacy & Transparency

Privacy & Transparency