Dupliquer des données en cherchant une couleur

Le 15/04/2020 à 11:52

Bonjour à tous,

J'ai une BDD sur la feuille "Nomenclature" et j'aimerais que toutes les données écrites en vert (colonnes G, H, I et J) se répercutent sur la BDD de la feuille "Composants".

Je ne sais pas si il faut utiliser une macro pour exécuter cette action ou si cela marche avec une formule ?

Je sais qu'il y a des données qui peuvent être en doublon mais j'aimerais qu'elles soient toutes affichées.

Merci par avance pour votre aide.

Vous trouverez ci-après mon fichier test :

15test.xlsx (45.22 Ko)

Julie S.

Le 15/04/2020 à 12:17

Bonjour Julie, bonjour le forum,

Essaie comme ça :

[code]Sub Macro1()

Dim OS As Worksheet 'déclare la varaible OS (Onglet Source)

Dim OD As Worksheet 'déclare la varaible OD (Onglet Destination)

Dim DL As Integer 'déclare la varaible DL (Dernière Ligne)

Dim K As Integer 'déclare la varaible K (incrément)

Dim I As Integer 'déclare la varaible I (Incrément)

Dim TL() As Variant 'déclare la varaible TL (Tableau des Lignes)

Dim DEST As Range 'déclare la varaible DEST (cellule de DEstination)

Set OS = Worksheets("Nomenclature") 'définit l'onglet OS

Set OD = Worksheets("Composants") 'définit l'onglet OD

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

K = 1 'initialise la variable K

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

'condition : si la couleur de la police de la cellule de la boucle est : vert

If OS.Cells(I, "G").Font.Color = 5287936 And OS.Cells(I, "G").Font.TintAndShade = 0 Then

ReDim Preserve TL(1 To 4, 1 To K) 'redimensionne le tableau des lignes (4 lignes, K colonnes)

TL(1, K) = OS.Cells(I, "G") 'récupère dans la ligne 1, la valeur de la cellule en colonne G de la boucle

TL(2, K) = OS.Cells(I, "H") 'récupère dans la ligne 2, la valeur de la cellule en colonne H de la boucle

TL(3, K) = OS.Cells(I, "I") 'récupère dans la ligne 3, la valeur de la cellule en colonne I de la boucle

TL(4, K) = OS.Cells(I, "J") 'récupère dans la ligne 4, la valeur de la cellule en colonne J de la boucle

K = K + 1 'incrément K (pour ajouter une colonne au tableau des lignes TL à la prochaine boucle)

End If 'fin de la condition

Next I 'prochaine ligne de la boucle

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

DEST.Resize(K - 1, 4).Value = Application.Transpose(TL) 'renvoie dans DEST redimensionnée le tablaeu TL transposé

End Sub[code]

Le 15/04/2020 à 14:48

Merci beaucoup ThauThème

Cela fonctionne par contre j'ai affecté la macro à un bouton et j'aimerais que dès que la personne clique une deuxième fois sur le bouton qu'il y est un MsgBox qui s'affiche en disant "Etes-vous sûr de vouloir copier les données en doublon ?" Yes No.

Est-ce que c'est possible ?

Merci par avance,

Julie S

Le 16/04/2020 à 10:17

Re bonjour,

J'ai de nouveau des modifications j'aimerais que toutes les données en doublon m'affichent une somme de la quantité.

Ex : J'aimerais passer de ça :

Pièce / Visserie Qt Qt/ligne Matière

Anneau truarc Ø7 56 224 Inox A2

Anneau truarc Ø7 40 160 Inox A2

Anneau truarc Ø7 16 48 Inox A2

A ça :

TOTAL

Anneau truarc Ø7 112 432 Inox A2

Merci par avance pour votre aide.

Julie S.

Le 16/04/2020 à 12:59

Bonjour Julie, bonjour le forum,

le code modifié :

Private TEST As Boolean 'déclare la variable TEST

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 DL As Integer 'déclare la variable DL (Dernière Ligne)
Dim I As Integer 'déclare la variable I (Incrément)
Dim J As Integer 'déclare la variable J (incrément)
Dim K As Integer 'déclare la variable K (incrément)
Dim D As Object 'déclare la variable D (Dictionnaire)
Dim TMP As Variant 'déclare la variable TMP (tableau TeMPoraire)
Dim TL() As Variant 'déclare la variable TL (Tableau des Lignes)
Dim DEST As Range 'déclare la variable DEST (cellule de DEstination)
Dim NTL() As Variant 'déclare la variable NTL (Nouveau Tableau des Lignes)

If TEST = True Then 'condition : Si TEST est [vrai]
    TEST = False 'TEST devient [faux]
    'si "Non" au message, sort de la procédure
    If MsgBox("Etes-vous sûr de vouloir copier les données en doublon ?", vbYesNo, "ATTENTIO") = vbNo Then Exit Sub
End If 'fin de la condition
Set OS = Worksheets("Nomenclature") 'définit l'onglet OS
Set OD = Worksheets("Composants") 'définit l'onglet OD
DL = OS.Cells(Application.Rows.Count, "G").End(xlUp).Row 'définit la dernière ligne éditée DL de la colonne G de l'onglet OS
K = 1 'initialise la variable K
For I = 2 To DL 'boucle des lignes 2 à DL
    'condition : si la couleur de la police de la cellule de la boucle est : vert et si elle n'est pas vide
    If OS.Cells(I, "G").Value <> "" And OS.Cells(I, "G").Font.Color = 5287936 And OS.Cells(I, "G").Font.TintAndShade = 0 Then
        ReDim Preserve TL(1 To 4, 1 To K) 'redimensionne le tableau des lignes (4 lignes, K colonnes)
        TL(1, K) = OS.Cells(I, "G") 'récupère dans la ligne 1, la valeur de la cellule en colonne G de la boucle
        TL(2, K) = OS.Cells(I, "H") 'récupère dans la ligne 2, la valeur de la cellule en colonne H de la boucle
        TL(3, K) = OS.Cells(I, "I") 'récupère dans la ligne 3, la valeur de la cellule en colonne I de la boucle
        TL(4, K) = OS.Cells(I, "J") 'récupère dans la ligne 4, la valeur de la cellule en colonne J de la boucle
        K = K + 1 'incrémente K (pour ajouter une colonne au tableau des lignes TL à la prochaine boucle)
    End If 'fin de la condition
Next I 'prochaine ligne de la boucle
Set D = CreateObject("Scripting.Dictionary") 'définit le dictionnaire D
For I = 1 To UBound(TL, 2) 'boucle sur toutes les lignes I du tableau des lignes TL
    D(TL(1, I) & " " & TL(4, I)) = "" 'alimente le dictionnaire avec la concaténation de de la pièce/visserie et de la matière
Next I 'prochaine ligne de la boucle
TMP = D.Keys 'récupère dans le tableau tmporaire TMP la liste des couples pièce/matière sans doublon
K = 1 'initialise la variable K
For J = 0 To UBound(TMP) 'boucle 1 : sur tous les couples J pièce/matière
    For I = 1 To UBound(TL, 2) 'boucle 2 : sur toutes les lignes I du tableau des lignes TL
        If TL(1, I) & " " & TL(4, I) = TMP(J) Then 'si le couple pièce/matière de la boucle 2 correspond à celui de la boucle 1
            ReDim Preserve NTL(1 To 4, 1 To K) 'redimensionne le nouveau tableau des lignes NTL (4 lignes K, colonnes)
            NTL(1, K) = TL(1, I) 'récupère dans la ligne 1 de NTL la données en ligne 1 de TL (Pièce/Visserie)
            NTL(2, K) = NTL(2, K) + TL(2, I) 'additionne dans la ligne 2 de NTL les données en lignes 2 de TL (Qt)
            NTL(3, K) = NTL(3, K) + TL(3, I) 'additionne dans la ligne 3 de NTL les données en ligne 3 de TL (Qt/Ligne)
            NTL(4, K) = TL(4, I) 'récupère dans la ligne 4 de NTL la données en ligne 4 de TL (Pièce/Visserie)
        End If 'fin de la condition
    Next I 'prochaine ligne de la boucle 2
    K = K + 1 'incrémente K (pour ajouter une nouvelle colonne au tableau NTL lors de la prochaine boucle 1)
Next J 'prochain élément de la boucle 1
Set DEST = OD.Cells(Application.Rows.Count, "A").End(xlUp).Offset(1, 0) 'définit la cellule de destination DEST
If K > 1 Then 'si K est supérieure à 1
    DEST.Resize(UBound(NTL, 2), 4).Value = Application.Transpose(NTL) 'renvoie dans DEST redimensionnée le tablaeu NTL transposé
End If 'fin de la condition
TEST = True 'redéfinit la variable TEST
OD.Activate 'active l'onglet OD
End Sub

Attention à ne pas oublier la première ligne qui se trouve en tête du module et hors de la procédure...

Rechercher des sujets similaires à "dupliquer donnees cherchant couleur"