Création d'une fonction de copie de la mise en forme

Bonjour,

Pour mon projet de fin d'étude je dois réaliser un tableau de listing des coloris contenant :

• Une colonne désignant l’élément
• Une colonne désignant sa couleur RAL
• Une colonne pour l'aperçu de la couleur

J'ai créé sur une autre feuille, une base de données contenant chaque couleur RAL avec son aperçu à côté.

Mon problème, je souhaite créer une fonction qui copie automatiquement l'aperçu de la couleur en fonction de la couleur RAL choisie et qu'elle se modifie automatiquement quand je change de couleur RAL.

Je me suis basé sur la commande Reproduire la mise en forme puisque c'est cette commande là que je veux transformer en fonction, j'ai utilisé l'enregistreur de macro afin d'obtenir le déroulement de la commande

et j'ai obtenu ça :

Sheets("Coloris pour rendu").Select
    Range("D4").Select
    Selection.Copy
    Sheets("Coloris Pour Rendu").Select
    Range("F3").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False

Et ce que je cherche à faire c'est transformer ça pour en faire une fonction où D4 sera remplacée par la cellule colorée issue de la base de données et F3, la cellule de destination qui est la cellule où se trouvera la formule.

Bonjour,

Si tu mets un modèle, on pourra construire une fonction pour faire ce que tu demandes.

Cordialement.

Le fichier Excel sur lequel je travaille.

Entrez un code RAL, dans la colonne Couleur RAL (exemple: 1014), le code HEX et la Dénomination apparaisse grâce à une RECHERCHEV.

Merci

Re,

Une fonction n'est pas adéquate pour colorer une cellule... On passe donc par une évènementielle réagissant à la saisie du code RAL en colonne C.

Quand un code est saisi en C, la cellule en F est colorée.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim coul&, n%, c As Range
    If Target.Row < 3 Then Exit Sub
    For Each c In Intersect(Target, Me.Columns(3))
        If c.Value <> "" Then
            On Error GoTo errcodral
            n = WorksheetFunction.Match(c.Value, [TABLEAU_COULEUR].Columns(1), 0)
            coul = [TABLEAU_COULEUR].Cells(n, 4).Interior.Color
            c.Offset(, 3).Interior.Color = coul
        Else
            c.Offset(, 3).Interior.ColorIndex = xlColorIndexNone
        End If
    Next c
errcodral:
End Sub

Tu trouveras la procédure dans le module de la feuille.

Dernier conseil : évite l'enregistreur, demande plutôt conseil, apprends à coder en VBA autrement que ce que fournit l'enregistreur (sans Select, sans Selection, sans Activate, sans CutCopyMode, sans énumération des propriétés laissées à leur valeur par défaut, liste non limitative) et tu auras des chances d'avoir un code mieux écrit et plus efficace.

Cordialement.

Je vous en remercie beaucoup !

J'aurai aimé, si possible, que vous m'expliquiez un peu le code que vous avez tapé car je voudrais comprendre ce que vous avez fait car je n'ai jamais réalisé d’événementielle sur Excel

Explications dans le code :

Private Sub Worksheet_Change(ByVal Target As Range) ' Proc. intervenant à changement valeur dans feuille, Target étant la plage modifiée
    Dim coul&, n%, c As Range  ' déclarations des variables
    If Target.Row < 3 Then Exit Sub  ' Interruption si Target est au-dessus de la ligne 3
    For Each c In Intersect(Target, Me.Columns(3))  ' balayage plage impactée (si comporte plusieurs cellules en col. C
        If c.Value <> "" Then ' si cellule comporte une valeur
            On Error GoTo errcodral '  gestion erreur renvoyant en fin proc si valeur n'est pas un code RAL
            n = WorksheetFunction.Match(c.Value, [TABLEAU_COULEUR].Columns(1), 0) ' Recherche ligne code dans tableau (fonction EQUIV)
            coul = [TABLEAU_COULEUR].Cells(n, 4).Interior.Color ' Récup. couleur dans col. 4 du tableau
            c.Offset(, 3).Interior.Color = coul ' affectation couleur en F en regard saisie du code
        Else ' si la cellule est vide ou a été effacée
            c.Offset(, 3).Interior.ColorIndex = xlColorIndexNone ' on enlève couleur éventuelle
        End If
    Next c
errcodral: ' étiquette renvoi erreur pour sortir procédure
End Sub

Codialement.

Merci pour tout !