Extraction de cellules en couleur

[amdur]

Bonjour,

Mon but est de faire une extraction des cellules en couleur (le fond de la cellule étant en couleur) pour chaque colonne de haut en bas ensuite on passe à la deuxième colonne etc... pour toute ma base et disposer ces données ainsi que la couleur du fond de cellule sur une seule colonne avec en titre de la colonne ce que je souhaite et ceci dans une autre feuille de calcul.

Svp comment dois-je adapter la macro qui a été proposée dans le sujet " extraire des cellules de couleur".


PS: Je suis novice en macro, svp quelque chose de simple à comprendre serait grandement apprécié.


Merci d'avance pour votre aide.


A bientôt.

 

[job75]

Re : Extraction de cellules en couleur

Bonjour amdur,

Bien que novice en macro, avec un peu d'effort vous devriez comprendre :

Sub Copie()
'Feuil1 et Feuil2 sont les CodeNames des feuilles
Dim P As Range, nlig As Long, col As Integer, lig As Long, n As Long
Set P = Feuil1.UsedRange 'source
nlig = P.Rows.Count
Feuil2.Rows("2:" & Rows.Count).Delete 'RAZ
n = 2 '1ère ligne de destination
For col = 1 To P.Columns.Count
  For lig = 1 To nlig
    If P(lig, col).Interior.ColorIndex <> xlNone Then
      With Feuil2.Cells(n, 1)
        .Value = P(lig, col)
        .Interior.Color = P(lig, col).Interior.Color
      End With
      n = n + 1 'ligne suivante
    End If
  Next
Next
Feuil2.Columns(1).AutoFit 'ajustement largeur
End Sub

Comme demandé, la macro copie la valeur et la couleur de la cellule colorée.

S'il faut d'autres mises en forme, joignez le fichier.

A+

 

[job75]

Re : Extraction de cellules en couleur

Re,

Si l'on veut copier toute la mise en forme on peut faire un Copier/Collage spécial-Formats :

Sub Copie()
'Feuil1 et Feuil2 sont les CodeNames des feuilles
Dim P As Range, nlig As Long, col As Integer, lig As Long, n As Long
Set P = Feuil1.UsedRange 'source
nlig = P.Rows.Count
Application.ScreenUpdating = False 'fige l'écran
Feuil2.Rows("2:" & Rows.Count).Delete 'RAZ
n = 2 '1ère ligne de destination
For col = 1 To P.Columns.Count
  For lig = 1 To nlig
    If P(lig, col).Interior.ColorIndex <> xlNone Then
      P(lig, col).Copy
      With Feuil2.Cells(n, 1)
        .PasteSpecial xlPasteFormats
        .Value = P(lig, col)
      End With
      n = n + 1 'ligne suivante
    End If
  Next
Next
Application.Goto Feuil2.[A1], True
Feuil2.Columns(1).AutoFit 'ajustement largeur
End Sub

A+

 

[Staple1600]

Re : Extraction de cellules en couleur

Bonjour à tous, salut job75

amdur
Dommage que j'ai pas vu ta nouvelle discussion avant.
Merci d'avoir inconsciemment devancé mon dernier conseil
https://www.excel-downloads.com/threads/extraire-les-cellules-de-couleurs.56738/
T'es trop fort (lol)

PS: il manque juste ton fichier exemple

 

[amdur]

Re : Extraction de cellules en couleur

Bonjour,

Je vous remercie pour votre éclairage et votre rapidité de réponse.

A bientôt.