Excel & VB - Motifs dans un rectangle

Question

Bonjour,

J'aurais souhaité avoir un conseil pour un programme Visual Basic sur Excel.

Voila :
Avec Visual je crée plusieurs rectangle sur ma feuille excel. Ces rectangles ont un remplissage blanc.

J'ai fais une sorte de nuancier en créant une 30 aine de petit rectangle avec un fond avec des couleurs et des motif particuliers.

Or je voudrais trouver une solution pour pouvoir choisir un remplissage de mes nouveaux rectangles crées avec VB à l'aide de ce "nuancier".

Je ne sais pas trop comment faire ... Je pensais à 2 solution :
1) Cliquer sur un des rectangle de mon nuancier et de le faire glisser vers mon nouveau rectangle afin que ce nouveau rectangle puisse obtenir la couleur du rectangle choisi dans mon nuancier ... Or ceci implique que le rectangle du nuancier à la suite de cette opération retourne à son emplacement dans le nuancier.

2) Créer un menu déroulant pour chaque rectangle à colorier (il y en aura 3 au maximum) montrant les motifs de mon nuancier. Ensuite le choix de cette couleur pourrait remplir automatiquement mon rectangle. 

Pouvez vous m'indiquer quelle serait la meilleure solution ou la plus faisable afin de me donner des pistes pour continuer ?

Par contre je ne sais pas comment faire pour faire ce menu déroulant incluant les nuances ... ni comment utliser une manip de style Drag & Drop ...

Merci à tous.

LePierre · Answer

Solution manuelle :
- clique sur le rectangle de la couleur à copier
- clique sur l'outil "Reproduire la mise en forme" (pinceau)
- clique sur ton rectangle à colorier

Solution macro :
Pour cet exemple, j'ai défini 3 rectangles modèles appelés : "Rectangle 1", "Rectangle 2", "Rectangle 3"
et j'ai ajouté un autre rectangle (celui que je veux colorier).
Sur ma feuille j'ai inscris dans la cellule adjacente à chaque rectangle modèle le N° correspondant (1, 2, 3)
Je sélectionne le rectangle à colorier et j'appelle la macro test (Alt + F8) et j'appuie sur "Exécuter"
J'indique dans la boîte de dialogue le N° du rectangle de la couleur à copier
Et voila le résulat.


Sub test()
    On Error Resume Next
    RectAcolorier = Selection.Name
    If RectAcolorier = "" Then
        MsgBox ("Sélectionnez le rectangle à colorier !")
        Exit Sub
    End If
    
    myNum = Application.InputBox("Enter a number")
    Rectangle = "Rectangle " & myNum
    ActiveSheet.Shapes(Rectangle).Select
    Selection.ShapeRange.PickUp
    
    ActiveSheet.Shapes(RectAcolorier).Select
    Selection.ShapeRange.Apply
End Sub

LePierre · Answer

par rapport à ma réponse précédente, je crois avoir trouvé "la" solution !

Solution macro : 
Pour cet exemple, j'ai défini 3 rectangles modèles auxquels est affectée la macro "RecopieCouleurs"
et j'ai ajouté un autre rectangle (celui que je veux colorier). 
Je clique gauche sur un rectangle modèle
Je clique droit sur le rectangle à colorier et je choisi la commande "Coller la couleur du rectangle" du menu contextuel.
Et voila le résulat. 

Sub RecopieCouleurs()
    CouleurRectangle = Application.Caller
    ActiveSheet.Shapes(CouleurRectangle).Select
    Selection.ShapeRange.PickUp
End Sub

Sub CollerCouleurs()
     Selection.ShapeRange.Apply
End Sub

Sub Auto_Open()
    Dim Menu_Contextuel As CommandBar
    Dim NewBtn As CommandBarComboBox
    Dim NewBtn2 As CommandBarControl
    
    Set Menu_Contextuel = Application.CommandBars("Shapes")
    'trait séparateur
    Menu_Contextuel.Controls.Add(before:=1).BeginGroup = True
    'Ajout menu
    Set NewBtn2 = Menu_Contextuel.Controls.Add(Type:=msoControlButton, before:=1)
    With NewBtn2
        .Caption = "Coller la couleur du rectangle"
        .BeginGroup = True
        .OnAction = "CollerCouleurs"
    End With
    'effacement ligne vide
    Menu_Contextuel.Controls.Item(2).Delete
End Sub

Sub Auto_Close()
    Application.CommandBars("Shapes").Reset
End Sub

Excel & VB - Motifs dans un rectangle

2 réponses

Discussions similaires

Newsletters