Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

placer et dimmensionner un rectangle automatiquement

Créer une discussion
  • Initiateur de la discussion Initiateur de la discussion olhey
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
O

olhey

XLDnaute Occasionnel
Bonjour,

J'ai un défi assez intéressant:

Comme vous allez le voir dans le fichier j'ai des ouvrages(ponts, tunnels, galerieS) qu'il faudrait placer dans un tableau par vba.

Le programme devrait:
1. calculer la longueur de l'ouvrage(km fin-km début)(=longeur du rectangle)
2. Calculer sa position par rapport à la ligne métrique(avec km début )(=position du rectangle)
3. puis en fonction de l'ouvrage lui attribuer la couleur adéquate

il s'agit de rectangle très très fin en fait. Il faudrait encore que le vba le place en au de la cellule, en fait comme dans l'exemple.

est ce que c'est possible à réaliser? Ca serait vraiment super 😉

MERCI les as😎
 

Pièces jointes

Trier par date Trier par votes
Re : placer et dimmensionner un rectangle automatiquement

Bonjour, Je m'ecuse platement de ne pas avoir fait signe plus tôt mais jai toujours cru que mon message était rester sans réponse! je suis entrain de tester les deux variantes.

Ya t il une version plus légère que l'autre(j'aurait pas mal d'élément à faire déssiner)?

Merci en tous cas et encore dsl de ne pas avoir répondu plus tôt
 
Vote positif 0 Vote négatif
Re : placer et dimmensionner un rectangle automatiquement

Je suis en train d'adapter le script à mon projet et il m'affiche une erreur de type 13

pour cette ligne...

Call AfficheOuvrage(.Range("D" & Cpt).Value, Origine, .Range("G" & Cpt).Value, .Range("J" & Cpt).Value - .Range("G" & Cpt).Value, Couleur)
 
Vote positif 0 Vote négatif
Re : placer et dimmensionner un rectangle automatiquement

J'ai décider d'utiliser la version de minick, plus facile pour ajouter des types d'ouvrages.

J'ai un problème car jai des ouvrages sur plus de 21 km(donc pas assez de colonne j'ai modifié le script pour qu'il continur sur une autre feuil mais j'ai un problème de permission

Je joint un fichier pour que vous puissier voir vous même
Code: 
ption Explicit

Sub AfficheOuvrage(Ouvrage As String, Origine As Range, posDeb As Double, Longueur As Double, Couleur As Integer)
    Dim Echelle As Double
    Dim posOuvrage As Integer
    
    Echelle = (Origine.Width / 100) * 1000
    
    If Not posDeb > 21 Then
        
    [COLOR="red"]With Feuil1[/COLOR].Shapes.AddShape(msoShapeRectangle, Origine.Left + (posDeb * Echelle), Origine.Top, Longueur * Echelle, 3)
        .Name = "Ouvrage_" & Ouvrage
        .Fill.ForeColor.SchemeColor = Couleur
        .Line.Visible = msoFalse
    End With
    
    Else
    [COLOR="red"]With Feuil3[/COLOR].Shapes.AddShape(msoShapeRectangle, Origine.Left + (posDeb * Echelle) - 210, Origine.Top, Longueur * Echelle, 3)
        .Name = "Ouvrage_" & Ouvrage
        .Fill.ForeColor.SchemeColor = Couleur
        .Line.Visible = msoFalse
    End With
    End If
    
    
    posOuvrage = ((posDeb + (Longueur / 2)) * Echelle) / Origine.Width

    Origine.Offset(, posOuvrage).Value = Ouvrage
End Sub

Sub CreationOuvrage()
    Dim Shp As Shape
    Dim Cpt As Integer, Couleur As Integer
    Dim Origine As Range
    Dim Ouvrage As String
    
    Application.ScreenUpdating = False
        For Each Shp In Feuil1.Shapes
            If Left(Shp.Name, 8) = "Ouvrage_" Then
                Shp.Delete
            End If
        Next Shp
        
        Feuil1.Range("F5:AN11").Clear
        With Feuil2
            For Cpt = 5 To Feuil2.Range("C65536").End(xlUp).Row
                If .Range("B" & Cpt).Value <> "" Then
                    Ouvrage = .Range("B" & Cpt).Value
                    Select Case Ouvrage
                        Case "ponts"
                            Couleur = 50
                            Set Origine = Feuil1.Range("F5")
                            
                        Case "tunels"
                            Couleur = 53
                            Set Origine = Feuil1.Range("F8")
                        
                        Case "galerie"
                            Couleur = 4
                            Set Origine = Feuil1.Range("F11")
                        
                        Case Else
                            Couleur = 0
                    End Select
                End If
                
                If Couleur <> 0 And .Range("C" & Cpt).Value <> "" And .Range("C" & Cpt).Value <> "no" Then
                    Call AfficheOuvrage(.Range("C" & Cpt).Value, Origine, .Range("F" & Cpt).Value, .Range("H" & Cpt).Value - .Range("F" & Cpt).Value, Couleur)
                End If
            Next Cpt
        End With
    Application.ScreenUpdating = True
End Sub

MERIC DE VOTRE AIDE PRECIEUSE.
 

Pièces jointes

Dernière édition:
Vote positif 0 Vote négatif
Re : placer et dimmensionner un rectangle automatiquement

Merci Minick t'es un as!!! j'ai juste encore un petit problème...

J'ai juste adapter les références de cellules, colonnes etc... à mon projet, tout fonctionne sauf qu'il dessine les rectangles mais sans les remplir de couleur... j'arrive à les selectionner mais ils sont ''invisible''.

Voyez vous même le printscreen

Merci bcp de votre aide
 

Pièces jointes

  • probleme1.jpg
    27.1 KB · Affichages: 52
Vote positif 0 Vote négatif
Re : placer et dimmensionner un rectangle automatiquement

Problème résolu en ajoutant:

Code: 
[...] With Origine.Parent.Shapes.AddShape(msoShapeRectangle, Origine.Left + (posDeb * Echelle), Origine.Top, Longueur * Echelle, 3)
        .Name = "Ouvrage_" & Ouvrage
        .Fill.ForeColor.SchemeColor = Couleur
        [COLOR="Red"].Fill.Visible = msoTrue[/COLOR]
        .Line.Visible = msoFalse
    End With [...]
 
Vote positif 0 Vote négatif
Re : placer et dimmensionner un rectangle automatiquement

Encore une question..

Si j'ai deux ouvrages du même type (ex: 2 ponts) qui son très proche il affiche seulement P2, il faudrait que si il ya déjà qqch d'écrit dans la case il affiche le nom de l'ouvrage dans la case suivant ou précédante...

Merci
 
Vote positif 0 Vote négatif
Re : placer et dimmensionner un rectangle automatiquement

Re,

Ajoute ceci
Code: 
While Origine.Offset(, posOuvrage).Value <> ""
        posOuvrage = posOuvrage + 1
    Wend
avant
Code: 
    Origine.Offset(, posOuvrage).Value = Ouvrage
 
Vote positif 0 Vote négatif
Re : placer et dimmensionner un rectangle automatiquement

MErci encore minick
fiouh.. j'ai encore un problème.

J'ai des types d'ouvrages (ex: parois anti bruit) qui si ils sont à gauche de la route devraient s'afficher en haut de la cellule et si ils sont à droite en bas.

J'ai penser rajouter un une colonne à ma "bd" avec des "g" et des "d" pour chauqe ouvrages qui ferais varier les paramètres du rectangle, au lieu d'avoir origine.top on aurait origine.bottom lorsque le contenu de cette colonne = d.

MERCI encore
 
Vote positif 0 Vote négatif
Identifiez-vous ou inscrivez-vous pour participer.
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

D
  • Question Question
Microsoft 365 Compléter un tableau de suivi automatiquement et bien compliqué :-)
Réponses
1
Affichages
2 K
herve62
N
  • Question Question
reporter automatiquement sur un planning de production
Réponses
4
Affichages
2 K
neim
N
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…