XL 2013 Suppression de toutes les lignes qui ne contiennent pas de couleur jaune

306255

XLDnaute Occasionnel
Bonsoir à tous,

J'ai un tableau qui comporte des milliers de lignes et les lignes possédant du jaune sont des lignes qu'il faut étudier, j'aimerais donc sur une autre feuille obtenir uniquement les lignes comportant du jaunes et les autres lignes peuvent être supprimées.

Merci pour votre aide
 

Pièces jointes

  • test couleur.xlsx
    9.8 KB · Affichages: 10

sylvanu

XLDnaute Barbatruc
Supporter XLD
Bonsoir 306255,
Certainement pas le plus rapide, risque même d'être long sur plusieurs milliers de lignes, mais j'ai pas trouvé mieux, au moins ce sera un truc qui marche en attendant une solution plus efficace, avec :
Code:
Sub MontreJaune()
    Dim L, C, p, DL, DC, T0
    Application.ScreenUpdating = False
    Sheets(1).Copy After:=Sheets(Sheets.Count)
    Sheets(Sheets.Count).Name = "Jaune"
    DL = 1 + Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row
    DC = 1 + Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, LookIn:=xlValues).Column
    Jaune = RGB(255, 255, 0)
    For L = 1 To DL
        Couleur = 0
        For C = 1 To DC
            If Cells(L, C).Interior.Color = Jaune Then Couleur = 1
        Next C
        Cells(L, "P") = Couleur
    Next L
    With ActiveSheet.Range("P1:P" & DL).Resize(ActiveSheet.UsedRange.Count)
        .AutoFilter Field:=1, Criteria1:="=0"
        Set p = .SpecialCells(xlVisible)
        .AutoFilter
    End With
    p.EntireRow.Delete shift:=xlUp
    [P:P].ClearContents
    ActiveWindow.ScrollRow = 1
    [A1].Select
End Sub
Lancer la macro par ALT+F8 et lancer MontreJaune.
Sur mon PC pour 1000 lignes, ça mets 0.5s.
 

Pièces jointes

  • test couleur (1).xlsm
    100.7 KB · Affichages: 1

mapomme

XLDnaute Barbatruc
Supporter XLD
Bonsoir à tous,

Une autre macro. Cliquez sur le bouton en bleu.

J'ai "dé-fusionné" les cellules de la colonne A et remis la valeur qu'il faut sur les cellules de chaque plage "dé-fusionnées". Pour 5 000 lignes, mon bouzin met environ 1 s (9 s pour 20 000 lignes). Dans la feuille "Les jaunes", ne pas utiliser la colonne P. Si nécessaire, on peut modifier le code pour rendre utilisable la colonne P (me le demander gentiment 😜).


Code dans module1:
VB:
Function enJaune(xPlage As Range)
Application.Volatile
Dim x
   enJaune = CVErr(xlErrNA)
   For Each x In xPlage
      If x.Interior.Color = vbYellow Then
         enJaune = xPlage.Row
         Exit Function
      End If
   Next x
End Function

Sub QueLesJaunes()
Dim source As Range, der&, i&, j&, deb
Application.ScreenUpdating = False
   deb = Timer
   With Sheets("Feuil1")
      der = .UsedRange.Row + .UsedRange.Rows.Count - 1
      Set source = .Range("a1:o" & der)
   End With
   With Sheets("Les Jaunes")
      Application.Goto .Range("a1"), True
      .Range("a:p").Clear
      source.Copy .Range("a1")
      For i = 1 To der
         If Cells(i, 1).MergeCells Then
            j = Cells(i, 1).MergeArea.Columns(1).Rows.Count
            Cells(i, 1).UnMerge
            Cells(i, 1).Resize(j) = Cells(i, 1).Value
         End If
      Next i
      .Range("p1").Formula2R1C1 = "=enJaune(RC[-15]:RC[-1])"
      .Range("p1").Copy .Range("p2").Resize(der - 1)
      .Range("p1").Resize(der).Calculate
      .Range("p1").Resize(der) = .Range("p1").Resize(der).Value
      .Range("a1:p1").Resize(der).Sort key1:=.Range("p1"), order1:=xlAscending, Header:=xlNo
      On Error Resume Next
      .Range("p1").Resize(der).SpecialCells(xlCellTypeConstants, xlErrors).EntireRow.Delete
      On Error GoTo 0
      i = Application.WorksheetFunction.Count(Columns("p:p"))
      Columns("p:p").Clear
      MsgBox i & " lignes en jaune extraites en " & Format(Timer - deb, "0.0 sec.")
   End With
End Sub
 

Pièces jointes

  • 306255- supptr test couleur- v1.xlsm
    469.3 KB · Affichages: 4
Dernière édition:

Robert

XLDnaute Barbatruc
Bonsoir numéro, bonsoir le forum,

En pièce jointe une proposition avec le code ci-dessous. Les cellules fusionnées et VBA ne sont pas bons copains d'où la bidouille pour faire fonctionner le code...

VB:
Sub Macro1()
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim PL As Range 'déclare la variable PL (PLage)
Dim TEST As Boolean 'déclare la variable TEST
Dim LI As Integer 'déclare la variable LI (LIgne)
Dim CEL As Range 'déclare la variable CEL (CELlule)
Dim NC As Integer 'déclare la variable NC (Nombre de Cellules)

Set OS = Worksheets("Feuil1") 'définit l'onglet source OS
Set OD = Worksheets("Feuil2") 'définit l'onglet destination OD
OD.Cells.Clear 'efface les anciennes données de l'onglet destination
Set PL = OS.UsedRange 'définit la plage PL
For LI = 1 To PL.Rows.Count 'boucle 1 : sur toutes les lignes LI de la plage PL
    TEST = False 'réinitialise la variable TEST
    For Each CEL In Application.Intersect(PL, OS.Rows(LI)) 'boucle 2 : sur toutes les cellule CEL de la ligne LI de PL
        If CEL.Interior.ColorIndex = 6 Then 'condition : si la couleur de la cellule est jaune
            NC = CEL.MergeArea.Cells.Count 'définit le nombre de cellule de la cellule CEL (à cause des cellules fusionnées)
            TEST = True 'définit la variable TEST
            'définit la cellule de destination DEST (A1 si A1 de l'onglet OD est vide, sinon la première cellule vide de la colonne A de l'onglet OD)
            Set DEST = IIf(OD.Range("A1").Value = "", OD.Range("A1"), OD.Cells(Application.Rows.Count, "A").End(xlUp).Offset(1, 0))
            Exit For 'sort de la boucle
        End If 'fin de la condition
    Next CEL 'prochaine cellule de la boucle 2
    If TEST = True Then 'condition : si TEST est [vrai]
        CEL.MergeArea.EntireRow.Copy DEST 'copie la lignes (ou les lignes si fusion)de la cellule CEL
        LI = LI + NC - 1 'incrémente LI di nombre de cellule NC moins une
    End If 'fin nde la condition
Next LI 'prochaine ligne de la boucle 1
OD.Activate 'active l'onglet OD
End Sub
Clique sur le bouton Récup. Le fichier :
 

Pièces jointes

  • Numéro_EP_v01.xlsm
    26.1 KB · Affichages: 6

Robert

XLDnaute Barbatruc
Bonsoir à tous,

Une autre macro. Cliquez sur le bouton en bleu.

J'ai "dé-fusionné" les cellules de la colonne A et remis la valeur qu'il faut sur les cellules de chaque plage "dé-fusionnées". Pour 5 000 lignes, mon bouzin met environ 1 s (9 s pour 20 000 lignes). Dans la feuille "Les jaunes", ne pas utiliser la colonne P. Si nécessaire, on peut modifier le code pour rendre utilisable la colonne P (me le demander gentiment 😜).


Code dans module1:
VB:
Function enJaune(xPlage As Range)
Application.Volatile
Dim x
   enJaune = CVErr(xlErrNA)
   For Each x In xPlage
      If x.Interior.Color = vbYellow Then
         enJaune = xPlage.Row
         Exit Function
      End If
   Next x
End Function

Sub QueLesJaunes()
Dim source As Range, der&, i&, j&, deb
Application.ScreenUpdating = False
   deb = Timer
   With Sheets("Feuil1")
      der = .UsedRange.Row + .UsedRange.Rows.Count - 1
      Set source = .Range("a1:o" & der)
   End With
   With Sheets("Les Jaunes")
      Application.Goto .Range("a1"), True
      .Range("a:p").Clear
      source.Copy .Range("a1")
      For i = 1 To der
         If Cells(i, 1).MergeCells Then
            j = Cells(i, 1).MergeArea.Columns(1).Rows.Count
            Cells(i, 1).UnMerge
            Cells(i, 1).Resize(j) = Cells(i, 1).Value
         End If
      Next i
      .Range("p1").Formula2R1C1 = "=enJaune(RC[-15]:RC[-1])"
      .Range("p1").Copy .Range("p2").Resize(der - 1)
      .Range("p1").Resize(der).Calculate
      .Range("p1").Resize(der) = .Range("p1").Resize(der).Value
      .Range("a1:p1").Resize(der).Sort key1:=.Range("p1"), order1:=xlAscending, Header:=xlNo
      On Error Resume Next
      .Range("p1").Resize(der).SpecialCells(xlCellTypeConstants, xlErrors).EntireRow.Delete
      On Error GoTo 0
      i = Application.WorksheetFunction.Count(Columns("p:p"))
      Columns("p:p").Clear
      MsgBox i & " lignes en jaune extraites en " & Format(Timer - deb, "0.0 sec.")
   End With
End Sub
[Édition]
Je navet pas rafraîchi quand j'ai envoyé ma proposition. Du coup, je n'avais pas vu les répondes de Sylvanu et de Mapomme que je salue en retard...
 

Discussions similaires

Statistiques des forums

Discussions
299 847
Messages
1 979 562
Membres
206 773
dernier inscrit
becaye80