Extraire ligne suivant couleur de police

[jeff1494]

Bonjour à tous;
J'aimerais savoir comment faire l'extraction d'une ligne entière d'une feuille A vers une feuille B si la couleur de police la cellule A de la ligne est rouge.

La feuille A contient une série de textes (Colonnes A à L). Certaines cellule de A ont une police de caractères rouge (ColorIndex = 3).
J'aimerais pouvoir par macro couper la ligne dont la cellelue A est en rouge pour la copier dans une feuille B.

J'espère avoir été clair. Sinon n'hésitez pas à poser des questions.
D'avance merci pour votre aide.
Bonne journée à tous.

 

[Robert]

Re : Extraire ligne suivant couleur de police

Bonjour Jeff, bonjour le forum,

Je te propose la macro suivante :

Sub Macro1()
Dim cel As Range 'déclare la variable cel (CELlule)
Dim dest As Range 'déclare la variable dest (DESTination)
Dim dl As Integer 'déclare la variable dl (Dernière Ligne)
Dim x As Integer 'déclare la variable x
 
With Sheets("Feuil1") 'prend en compte l'onglet "Feuil1"
    dl = .Range("A65536").End(xlUp).Row 'définit la variable dl
    For x = dl To 1 Step -1 'boucle inversée sur toutes les cellules éditées de la colonne A (de la dernière à la première)
        If .Cells(x, 1).Font.ColorIndex = 3 Then 'condition 1 : si la couleur d'encre de la cellule est rouge
            If Sheets("Feuil2").Range("A1").Value = "" Then 'condition 2 : si A1 de l'onglet "Feuil2" est vide
                Set dest = Sheets("Feuil2").Range("A1") 'définit la variable dest (A1)
            Else 'sinon
                Set dest = Sheets("Feuil2").Range("A65536").End(xlUp).Offset(1, 0) 'définit la variable dest (la première cellule vide)
            End If 'fin de la condition 2
            .Cells(x, 1).EntireRow.Cut dest 'coupe et colle la ligne
            .Cells(x, 1).Delete shift:=xlShiftUp 'supprime la ligne vide
        End If 'fin de la condition 1
    Next x 'prochaine cellule de la colonne A
End With 'fin de la prise en compte de l'onglet "Feuil1"
End Sub

 

[jeff1494]

Re : Extraire ligne suivant couleur de police

Bonjour Robert;
Tout d'abord un grand merci pour ta réponse.
Je vais tester cala tout de suite.
J'ai testé, mais je rencontre quelque soucis.
En effet lorsque je lance la macro, cela copie bien la ligne sur la feuille 2, mais par contre certaines cellules de la ligne suivante effacées.
Je vais vérifier plus en avant ce qui peut bien se passer, et te tiens au courant.
Bonne journée à tous.

 

[jeff1494]

Re : Extraire ligne suivant couleur de police

Re-bonjour Robert;

Bien j'ai testé ta macro, mais des choses bizarres sont présentes.
Je joins un fichier exemple pour que tu puisses voir par toi même.
Encore merci pour ton aide.
Cordialement.

 

[natorp]

Re : Extraire ligne suivant couleur de police

Bonjour jeff1494 et Robert

je crois qu'il y a une anomalie à la ligne :
.Cells(x, 1).Delete shift:=xlShiftUp 'supprime la ligne vide

Il faut mettre : .Cells(x, 1).EntireRow.Delete shift:=xlShiftUp 'supprime la ligne vide

Cordialement, Gérard

 

[Robert]

Re : Extraire ligne suivant couleur de police

Bonjour Jeff, bonjour le forum,

En effet Jeff il y avait une erreur ! Je ne supprimais que la cellule de la colonne A au lieu de supprimer la ligne entière. Avec ton exemple j'ai modifié la macro pour que les lignes tansférées apparaissent dans le même ordre que dans l'onglet A TRIER. Du coup, deux boucles au lieu d'une seule. Une pour copier, la seconde pour supprimer les lignes vides...

Sub Depl_Lig()
'
'***************************************************************************************
'*
'* Macro de déplacement de lignes d'une feuille à une autre suivant critères
'*
'***************************************************************************************
'
Dim cel As Range 'déclare la variable cel (CELlule)
Dim dest As Range 'déclare la variable dest (DESTination)
Dim dl As Integer 'déclare la variable dl (Dernière Ligne)
Dim x As Integer 'déclare la variable x
 
Application.ScreenUpdating = False 'masque les changements à l'écran
With Sheets("A TRIER") 'prend en compte l'onglet "Feuil1"
    dl = .Range("A65536").End(xlUp).Row 'définit la variable dl
    'boucle inversée sur toutes les cellules éditées de la colonne A (de la dernière à la première)
    For Each cel In .Range("A2:A" & dl)
        'condition 1 : si la couleur d'encre de la cellule est rouge
        If cel.Font.ColorIndex = 3 Then
            Set dest = Sheets("Inactifs").Range("A65536").End(xlUp).Offset(1, 0)
            'coupe et colle la ligne
            cel.EntireRow.Cut dest
        End If
    Next cel
    'boucle inversée sur toutes les cellules éditées de la colonne A (de la dernière à la première)
    For x = dl To 1 Step -1
        'condition 1 : si cellule est vide
        If .Cells(x, 1).Value = "" Then
            .Rows(x).Delete shift:=xlShiftUp 'suprime la ligne
        End If
    Next x
End With
Application.ScreenUpdating = True 'affiche les changements à l'écran
End Sub

Édition :

Oui Nartop c'est exactement ça ! Merci pour ta rectification.

 

[jeff1494]

Re : Extraire ligne suivant couleur de police

Merci Robert, et natorp;
C'est Tiptop.
Encore un grand merci pour votre aide, et bonne journée à tous.
Merci Robert pour les commentaires dans le code cela me permet d'apprendre, et surtout de comprendre ce que tu as fait.
Cordialement.

 

[CG2000]

Re : Extraire ligne suivant couleur de police

Bonjour Robert, Jeff et le forum,

Est-il possible au lieu de repporter ces lignes sur une autre feuille du classeur, de creer un nouveau classeur en y incluant ces lignes ?

Merci par avance de votre aide.

CG2000