VBA Copier/coller des cellules si fond coloré

Le 23/08/2018 à 16:43

Bonjour,

Je n'ai jamais utilisé de forum mais je suis dans une situation qui dépasse mais connaissances...

Toute aide est la bienvenue

Alors pour résumer la situation:

J'ai toute une liste d'article (nom, réf, prix, conditionnement). Pour monter qu'un article m’intéresse, je colore le fond de la case "référence" en jaune. (je le fais manuellement sans mise en forme conditionnelle)

Ce que je cherche à faire c'est copier les références que j'ai choisi (donc uniquement les cases avec le fond jaune). Cela pour ensuite les coller dans une autre feuille.

Au final (dans l'idéal) j'aurai ma liste de fourniture et une feuille qui regroupe UNIQUEMENT les références que j'ai sélectionné.

Alors pour le moment c'est un remplissage jaune mais je peut adapter en fonction du plus simple. Par exemple en mettant en gras...

Merci à ceux qui prendrons le temps de me répondre, et si je ne suis pas clair n'hésitez pas!!!

Le 23/08/2018 à 17:21

Bonjour et bienvenue sur le forum

Un essai à tester. Te convient-il ?

Bye!

42classeur1-v1.xlsm (19.52 Ko)
Le 23/08/2018 à 17:23

Bonjour Lmart, bonjour e forum,

Pour éviter de perdre du temps, un petit fichier exemple, reprenant la structure de ton fichier original,nous permettrait de mieux répondre à ton problème...

[Édition]

Bonjour Gmb, nos posts se sont ccroisés...

Le 24/08/2018 à 12:00

Bonjour gmb et ThauThème

Tout d'abord merci beaucoup pour la rapidité de vos réponses!!!

gmb ta macro marche parfaitement mais j'ai du mal à l'adapter à mon tableur....

Du coup comme me le conseille ThauThème, voici un modèle du tableau que j'ai.

Il ressemble beaucoup à celui que bmb a réalisé mais dans mon cas il y a une colonne "ancien prix" qui ne m’intéresse pas (je ne veux pas la voir figurer dans les nouveaux tableaux).

Merci pour votre aide!!!!!

18modele-tableur.xlsm (10.90 Ko)
Le 24/08/2018 à 12:28

Bonjour le fil, bonjour le forum,

En pièce jointe ton fichier modifié avec la macro ci-dessous :

Sub Macro1()
Dim C As Worksheet 'déclare la variable C (onglet Comparatif)
Dim A As Worksheet 'déclare la variable A (onglet fournisseur A)
Dim B As Worksheet 'déclare la variable B (onglet fournisseur B)
Dim I As Integer 'déclare la variable I (Incréemnt)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)

Set C = Worksheets("Comparatif") 'définit l'onglet C
Set A = Worksheets("Fournisseur A") 'définit l'onglet A
Set B = Worksheets("Fournisseur B") 'définit l'onglet B
A.Rows("2:" & Application.Rows.Count).Clear 'efface les anciennes valeurs de l'onglet A
B.Rows("2:" & Application.Rows.Count).Clear 'efface les anciennes valeurs de l'onglet B
DL = C.Cells(Application.Rows.Count, "A").End(xlUp).Row 'définit la dernière ligne éditée DL de la colonne A de l'onglet C
For I = 4 To DL 'boucle des lignes 4 à DL
    If C.Cells(I, "B").Interior.Color = 65535 Then 'si la cellule en colonne B est jaune
        Set DEST = A.Cells(Application.Rows.Count, "A").End(xlUp).Offset(1, 0) 'définit la cellule de destination DEST dans l'onglet A
        Cells(I, "B").Copy DEST 'copie la rèf
        Cells(I, "D").Copy DEST.Offset(0, 1) 'copie le Nouv px
        Cells(I, "E").Copy DEST.Offset(0, 2) 'copie le cdt
    Else 'sinon
        Set DEST = B.Cells(Application.Rows.Count, "A").End(xlUp).Offset(1, 0) 'définit la cellule de destination DEST dans l'onglet B
        Cells(I, "F").Copy DEST 'copie la rèf
        Cells(I, "H").Copy DEST.Offset(0, 1) 'copie le Nouv px
        Cells(I, "I").Copy DEST.Offset(0, 2) 'copie le cdt
    End If 'fin de la condition
Next I 'prochaine ligne de la boucle
End Sub

Le fichier :

19lmart.xlsm (20.03 Ko)
Le 24/08/2018 à 14:57

Re-bonjour,

ThauThème ta macro marche super bien!!!

Comme je voulais que le nom soit aussi copié, je l'ai rajouté à la macro, mais il reste un minuscule détail.

Quand on copie dans les nouvelles pages, j'aimerais que les données soient copiées en commençant sur la ligne 3 et pas la 1. Avec mes modifications, il commence bien à la ligne 3 mais espace de 1 toutes les lignes suivantes...

Voici la macro et le fichier (avec la macro modifiée)pour que vous puissiez voir plus facilement.

Merci !!!!!

11lmart.xlsm (19.69 Ko)

Sub Macro1()

Dim C As Worksheet 'déclare la variable C (onglet Comparatif)

Dim A As Worksheet 'déclare la variable A (onglet fournisseur A)

Dim B As Worksheet 'déclare la variable B (onglet fournisseur B)

Dim I As Integer 'déclare la variable I (Incréemnt)

Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)

Set C = Worksheets("Comparatif") 'définit l'onglet C

Set A = Worksheets("Fournisseur A") 'définit l'onglet A

Set B = Worksheets("Fournisseur B") 'définit l'onglet B

A.Rows("2:" & Application.Rows.Count).Clear 'efface les anciennes valeurs de l'onglet A

B.Rows("2:" & Application.Rows.Count).Clear 'efface les anciennes valeurs de l'onglet B

DL = C.Cells(Application.Rows.Count, "A").End(xlUp).Row 'définit la dernière ligne éditée DL de la colonne A de l'onglet C

For I = 4 To DL 'boucle des lignes 4 à DL

If C.Cells(I, "B").Interior.Color = 65535 Then 'si la cellule en colonne B est jaune

Set DEST = A.Cells(Application.Rows.Count, "A").End(xlUp).Offset(2, 0) 'définit la cellule de destination DEST dans l'onglet A

Cells(I, "A").Copy DEST 'copie le nom

Cells(I, "B").Copy DEST.Offset(0, 1) 'copie la rèf

Cells(I, "D").Copy DEST.Offset(0, 2) 'copie le Nouv px

Cells(I, "E").Copy DEST.Offset(0, 3) 'copie le cdt

Else 'sinon

Set DEST = B.Cells(Application.Rows.Count, "A").End(xlUp).Offset(2, 0) 'définit la cellule de destination DEST dans l'onglet B

Cells(I, "A").Copy DEST 'copie le nom

Cells(I, "F").Copy DEST.Offset(0, 1) 'copie la rèf

Cells(I, "H").Copy DEST.Offset(0, 2) 'copie le Nouv px

Cells(I, "I").Copy DEST.Offset(0, 3) 'copie le cdt

End If 'fin de la condition

Next I 'prochaine ligne de la boucle

End Sub

Le 26/08/2018 à 14:15

Re,

Essaie comme ça :

If A.Range("A3").Value = "" then Set DEST = A.Range("A3") Else Set DEST = A.Cells(Application.Rows.Count, "A").End(xlUp).Offset(1, 0)

Idem pour l'onglet B...

Le 26/08/2018 à 15:41

Bonjour, Salut gmb, ThauThème !

Autre méthode :

Sub RéfFnr()
    Dim aa, kA, kB, tbA(), tbB(), i&, nA&, nB&
    aa = ActiveSheet.Range("A1").CurrentRegion
    kA = Array(1, 2, 4, 5): kB = Array(1, 6, 8, 9)
    ReDim tbA(nA): tbA(nA) = WorksheetFunction.Index(aa, 3, kA)
    ReDim tbB(nB): tbB(nB) = WorksheetFunction.Index(aa, 3, kB)
    With ActiveSheet
        For i = 4 To UBound(aa)
            If .Cells(i, 2).Interior.Color = vbYellow Then
                nA = nA + 1: ReDim Preserve tbA(nA)
                tbA(nA) = WorksheetFunction.Index(aa, i, kA)
            ElseIf .Cells(i, 6).Interior.Color = vbYellow Then
                nB = nB + 1: ReDim Preserve tbB(nB)
                tbB(nB) = WorksheetFunction.Index(aa, i, kB)
            End If
        Next i
    End With
    With Worksheets("Fournisseur A").Range("A3")
        .CurrentRegion.Clear
        With .Resize(nA + 1, 4)
            .Columns(2).NumberFormat = "@"
            .Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(tbA))
            .Columns(3).HorizontalAlignment = xlRight
            .Rows(1).HorizontalAlignment = xlCenter
            .Borders.Weight = xlThin
        End With
    End With
    With Worksheets("Fournisseur B").Range("A3")
        .CurrentRegion.Clear
        With .Resize(nB + 1, 4)
            .Columns(2).NumberFormat = "@"
            .Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(tbB))
            .Columns(3).HorizontalAlignment = xlRight
            .Rows(1).HorizontalAlignment = xlCenter
            .Borders.Weight = xlThin
        End With
    End With
End Sub

Bouton pour tester.

Cordialement.

23lmart166-modele-tableur.xlsm (25.86 Ko)
Le 27/08/2018 à 09:13

Bonjour,

Merci à MFerrand et ThauThème, vos deux solutions fonctionnent très bien.

Merci pour votre aide!!!!!

Rechercher des sujets similaires à "vba copier coller fond colore"