Lister les cellules de couleurs d'un tableau

Question

Je n'ai pas de connaissance en VBA et je n'ai pas la solution à mon problème avec des formules. Je souhaiterais, à partir d'un tableau à 2 colonnes, (1 colonne nom_article et 1 colonne prix_article), extraire un tableau dans un autre onglet de préférence, qui ne reprendrait que les lignes pour lesquelles la cellule du prix_article serait en couleur (couleur changée manuellement) Je joins un petit fichier exemple avec un tableau de base et au autre tableau résultat souhaité Je vous remercie d'avance pour le temps que vous voudrez bien m'accorder, Si pas VBA tant mieux, sinon je tacherais d'imbriquer tout ça dans mon fichier Merci à vous Stéphane...

MFerrand · Answer

A adapter selon ta configuration finale : Sub ExtractionCouleur() Dim Ext(), n%, i%, j% With ActiveSheet n = .Cells(.Rows.Count, 1).End(xlUp).Row ReDim Ext(1, n) Ext(0, 0) = .Cells(3, 1): Ext(1, 0) = .Cells(3, 2) For i = 4 To n If .Cells(i, 2).Interior.ColorIndex &lt;&gt; xlColorIndexNone Then j = j + 1 Ext(0, j) = .Cells(i, 1): Ext(1, j) = .Cells(i, 2) End If Next i End With ReDim Preserve Ext(1, j) With Worksheets.Add .Range("A1").Resize(j + 1, 2).Value = WorksheetFunction.Transpose(Ext) End With End Sub Cordialement...

Cappe Pierre · Answer

Je suis fervent de cette formule, que j'ai adaptée pour coller les résultat sur la même feuille, mais je n'arrive pas a supprimer les lignes de titres collées en même temps que les valeurs de couleurs. Fernand, peux-tu me rectifier ce code S'il te plait. un grande merci et toute mon amitié Pierrot ' Modification copier résultat sur la même feuille 'Sans ajouter les titres a chaque fois Sub ExtractionCouleur() Dim Ext(), n%, i%, j% With ActiveSheet n = .Cells(.Rows.Count, 1).End(xlUp).Row '1 ReDim Ext(1, n) Ext(0, 0) = .Cells(3, 1): Ext(1, 0) = .Cells(3, 2) For i = 4 To n If .Cells(i, 2).Interior.ColorIndex &lt;&gt; xlColorIndexNone Then j = j + 1 Ext(0, j) = .Cells(i, 1): Ext(1, j) = .Cells(i, 2) End If Next i End With ReDim Preserve Ext(1, j) ' With Range("E1000").Select Selection.End(xlUp).Select ActiveCell.Offset(1, 0).Range("A1").Select ActiveCell.Range("A1").Resize(j + 1, 2).Value = WorksheetFunction.Transpose(Ext) ' .Range("A1").Resize(j + 1, 2).Value = WorksheetFunction.Transpose(Ext) ' End With End Sub...

MFerrand · Answer

J'avais inclus les titres pour transfert sur une autre feuille... mais si tu veux les éviter : Ext(0, 0) = .Cells(3, 1): Ext(1, 0) = .Cells(3, 2) Ce sont ces deux lignes qui prennent les titres : donc supprimer. Et ajuster le dimensionnement : ReDim Ext(1, 1 To n) Si j'ai bien compris, cela suffit ! NB- Par souci esthétique, on peut préférer aligner les indices de départ des deux dimensions : ReDim Ext(1 To 2, 1 To n) Il faut alors modifier aussi : Ext(1, j) = .Cells(i, 1): Ext(2, j) = .Cells(i, 2) Cordialement...

MFerrand · Answer

Digère !

Pour faciliter, une dernière explication : j'ai inversé lignes et colonnes dans le tableau Ext (d'où la transposition lors de l'affectation finale), ceci parce que le nombre de colonnes est fixe et le nombre de lignes variable. Le tableau est déclaré comme tableau dynamique (donc à dimensionner lors de l'exécution), un tableau dynamique peut être redimensionné en conservant les valeurs déjà affectées, mais seulement en ce qui concerne la dernière dimension (d'où les lignes placées en 2e et dernière dimension), cela permet de dimensionner sur le nombre de ligne global de ta base au départ (n) et de le réduire à la fin au nombre de lignes qu'on a effectivement affectées (comptées avec j). On n'a ainsi qu'un ReDim Preserve à la fin (au lieu d'en faire un à chaque tour où l'on ajouterait une ligne...)

Cordialement.

MFerrand · Answer

Si l'objectif est d'obtenir à partir de de ta Feuil1 les 3 feuilles suivantes, la macro peut tout à fait être adaptée pour le faire (y compris l'ajout des feuilles et avec un nombre de colonnes clients variable dans le première)...

MFerrand · Answer

Je n'ai pas dit que je t'abandonnais à ce stade ! Mais je n'ai que 2 bras... et quelques obligations (même en vacances) ! A+ Mais cela reste une bonne idée de regarder les cours VBA.....

Cappe Pierre · Answer

Un tout grand merci, c'est parfait , après avoir modifié le code, tout fonctionne comme je le souhaitais. Merci et bonne fin de journée Amicalement Pierrot...

MFerrand · Answer

Voilà la nouvelle version à tester :

Sub ExtractionClientsCouleur()
    Dim Ext(), nl%, nk%, i%, j%, k%, cli$, fc As Worksheet
    With ActiveSheet
        nl = .Cells(.Rows.Count, 1).End(xlUp).Row
        nk = .Cells(1, .Columns.Count).End(xlToLeft).Column
        Application.ScreenUpdating = False
        For k = 2 To nk
            ReDim Ext(1, nl)
            Ext(0, 0) = .Cells(1, 1): cli = .Cells(1, k): Ext(1, 0) = cli
            For i = 2 To nl
                If .Cells(i, k).Interior.ColorIndex <> xlColorIndexNone And _
                 .Cells(i, k) <> "" Then
                    j = j + 1
                    Ext(0, j) = .Cells(i, 1): Ext(1, j) = .Cells(i, k)
                End If
            Next i
            ReDim Preserve Ext(1, j)
            Set fc = Worksheets.Add(after:=Worksheets(Worksheets.Count))
            fc.Name = cli
            fc.Range("A1").Resize(j + 1, 2).Value = WorksheetFunction.Transpose(Ext)
            Erase Ext: j = 0
        Next k
        Application.ScreenUpdating = True
    End With
End Sub

Pour faciliter la lecture du code, note que si une ligne se termine par espace suivi de underscore, c'est un indicateur de continuité, c'est toujours la même ligne de code qui se poursuit en dessous :

                If .Cells(i, k).Interior.ColorIndex <> xlColorIndexNone And _
                 .Cells(i, k) <> "" Then

Ci-dessus, une seule ligne de code.

A l'inverse le signe deux-points est un séparateur permettant d'écrire plusieurs lignes de code sur la même ligne :

            Ext(0, 0) = .Cells(1, 1): cli = .Cells(1, k): Ext(1, 0) = cli

Ci-dessus, 3 lignes de code.

Cordialement.

26doublefogg-test2-spa.xlsm (38.33 Ko)