Dessiner un rectangle à partir de données d'un Excel (2003)

Question

Sous excel 2003, j'ai des tableaux de calcul contenant des données chiffrées dans les colonnes H et I. je souhaiterais disposer d'une macro qui, lorsque je me placerai sur une ligne "l" et que je cliquerai sur le bouton "macro" correspondant, me dessine un rectangle de côtés proportionnels à H et I sur la droite de ma feuille de calcul (je le déplacerai ensuite pour combiner les différents rectangles correspondants aux lignes "l", "l+1", "l+2", ... à ma guise) L'objectif est de pouvoir établir rapidement un petit croquis de logement à partir de mon tableau de calcul des surfaces des pièces A ....... H I 1 Séjour : 5,20 3,15 (rectangle de H1 x I1) 2 Cuisine : 2,20 3,15 (rectangle de H2 x I2) 3 0,80 0,50 -1 (rectangle de H3 x I3) 4 Salon : ...... etc ... Quelqu'un sait-il comment procéder ? Merci...

vba-new · Accepted Answer

Re, c'est parce qu'il faut copier le second tableau de codes dans le classeur même et non dans perso.xls. ThisWorkbook = Ce classeur (et pas un autre ) Je pense que ça vient de là...

vba-new · Answer

Bonjour et bienvenue sur ce forum (tout neuf )

Est-il possible d'avoir un bout de fichier histoire de voir la réélle disposition des données?

Sinon, voir en pièce jointe un petit exemple basique.

1'341rectangle.zip (9.75 Ko)

vba-new · Answer

Re,

Il faut ouvrir l'éditeur VBE (Alt + F11) pour pouvoir coller les différents codes.

Voici les codes :

1. Le premier est à mettre dans 'ThisWorkbook'.

Private Sub Workbook_BeforeClose(Cancel As Boolean)
'Procédure appelante ajout d'un menu avec n items
    SuprMenuX ("Création &Rectangle")
End Sub

Private Sub Workbook_Open()
' remplacer NomDuMenu, NomItemX, ProcedureX (le nombre d'items et de procédures doit être identique
    AjMenuX "Création &Rectangle", Array("Dessiner"), Array("dessRectangle")
End Sub

2. Ensuite ajoute un module en faisant clic droit (sur ThisWorkbook par exemple) puis "Insertion" -> "Module" puis colle le code suivant :

Sub dessRectangle()
Dim h As Single, l As Single
Dim ligneActive As Integer
Dim nomPiece As String
    On Error GoTo dessRectangle_Error

    ligneActive = Right(ActiveCell.Address, Len(ActiveCell.Address) - InStr(2, ActiveCell.Address, "$"))
    h = Cells(ligneActive, 8) * 20
    l = Cells(ligneActive, 9) * 20
    nomPiece = Cells(ligneActive, 4)
    ActiveSheet.Shapes.AddShape(msoShapeRectangle, 306.75, 108#, l, h).Select
    Selection.Characters.Text = nomPiece
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With
    Selection.ShapeRange.LockAspectRatio = msoTrue
    'Selection.ShapeRange.Height = 94.5
    'Selection.ShapeRange.Width = 69#
    With Selection
        .Placement = xlFreeFloating
        .PrintObject = True
    End With

    On Error GoTo 0
    Exit Sub

dessRectangle_Error:

    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure dessRectangle of Module Module1"
End Sub
Sub AjMenuX(NomMenu, TbItem, TbLien)
' Procédure d'ajout d'un menu
'http://www.vbfrance.com/code.aspx?ID=27522

    Set myMenuBar = CommandBars.ActiveMenuBar
    Set newMenu = myMenuBar.Controls.Add(Type:=msoControlPopup, Temporary:=True)
    newMenu.Caption = NomMenu
    For Each Value In TbItem
        Set ctrl1 = newMenu.Controls.Add(Type:=msoControlButton, ID:=i + 1)
        ctrl1.Caption = Value
        ctrl1.TooltipText = Value
        ctrl1.Style = msoButtonCaption
        ctrl1.OnAction = TbLien(i)
        i = i + 1
    Next Value
End Sub

Sub SuprMenuX(NomMenu As String)
'Procédure de supperssion d'un menu
    On Error Resume Next
    Set myMenuBar = CommandBars.ActiveMenuBar
    myMenuBar.Controls(NomMenu).Delete
End Sub

Ça devrait marcher!

dubois · Answer

Vba-new , excellent "rectangle.xls" ActiveSheet.Shapes.AddShape msoShapeRectangle, 306.75, 108#, l, h serais-tu coder pour dimensionner un rectangle existant (en le sélectionnant par exemple) ? Amicalement Claude. édit 27/11 10h Bizarre ! j'avais essayé récemment et çà ne marchait pas, il est vrai qu'il s'agissait d'image. avec des rectangles c'est bon. Pour compléter: Sub dimensionner2() Dim h As Single, L As Single, Rect h = Cells(2, 1) * 20 L = Cells(2, 2) * 20 Rect = Cells(2, 3) With ActiveSheet.Shapes(Rect) .Select .Left = 500 'départ horiz .Top = 25 'départ vert .Width = L 'larg .Height = h 'haut End With End Sub encore merci Claude...

vba-new · Answer

Si un rectangle est sélectionné, tu peux utiliser le code suivant : Sub dimensionner() Selection.Width = 50 Selection.Height = 50 End Sub Sachant qu'il existe aussi les propriétés Left et Top qui permettent de placer ton rectangle. Les "50" étant des exemples, tu peux mettre n'importe quel chiffre à la place...