[ RESOLU ] Obtenir un schéma de principe selon un tableau

[polobeg]

Bonjour à vous tous,

Je me retourne une fois de plus vers vous car pleinement satisfait des réponses obtenues précédemment.

Voici ma demande j'aimerai savoir si cela est possible d'avoir un schéma de principe d'apres des images selon un tableau qui est préalablement rempli.

Je joints un fichier excel qui sera sans aucun doute plus parlant.

Merci d'avance à tous ceux qui y regarderont
Cordialement

 

[job75]

Re : Obtenir un schéma de principe selon un tableau

Bonjour polobeg,

PENSEZ VOUS QUE CELA EST REALISABLE ?

Tout est réalisable, à condition d'être clair :

- à quoi servent les colonnes "Hauteur FOND" et "Hauteur totale" ?

- place-t-on toujours "FDR ht 100" - "Picture 65" ou "Picture 71" - puisqu'il n'y a pas de colonnes correspondantes ?

- que fait-on si le tableau A3:N9 a plusieurs lignes renseignées ?

A+

 

[polobeg]

Re : Obtenir un schéma de principe selon un tableau

Bonjour Job,

Je répond à tes questions directement sur le fichier joint.

Merci
Cordialement

 

[Modeste geedee]

Re : Obtenir un schéma de principe selon un tableau

Bonsour®
une proposition entièrement graphique sans macro
seule la mise à l'échelle des constituants est manquante

il est possible de rajouter contrôle d'unicité pour dalle, réduction et fond

 

[job75]

Re : Obtenir un schéma de principe selon un tableau

Re, salut Modeste geedee,

Voyez le fichier joint et ce code :

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, [A6:N9]) Is Nothing Then Exit Sub 'plage à adapter
Dim lig, x#, y#, s As Shape
Cancel = True
lig = Target.Row - 3
'---initialisation à adapter
x = [J15].Left + [J15].Width / 2
y = [J15].Top
'---RAZ à adapter---
Application.ScreenUpdating = False
For Each s In Shapes
  If Not Intersect(s.TopLeftCell, [J14:N1000]) Is Nothing Then s.Delete
Next
'---Copies des Shapes à adapter---
CopieShape [K4:M4], lig, Shapes("Picture 66"), x, y, "Réhausse"
CopieShape [J4], lig, Shapes("Picture 63"), x, y, "Dalle"
CopieShape [E4:I4], lig, Shapes("Picture 67"), x, y, "TR"
CopieShape [B4:D4], lig, Shapes("Picture 64"), x, y, "ED"
If y > [J15].Top Then CopieShape [A4], lig, Shapes("Picture 65"), x, y, "FDR ht", 1
Application.ScreenUpdating = True
End Sub

Sub CopieShape(r As Range, lig, s As Shape, x#, y#, titre$, Optional der As Byte = 0)
Dim i, h#, w#
For Each r In r
  For i = 1 To IIf(der, 1, Val(r(lig)))
    s.Copy
    Paste
    Selection.Left = x
    Selection.Top = y
    h = Selection.Height
    w = Selection.Width
    y = y + h
    OLEObjects("Label1").Copy
    Paste
    Selection.Object.WordWrap = False
    Selection.Object.AutoSize = False
    Selection.Object.Caption = titre & " " & _
      IIf(der, 100 * Val(Replace(r(lig), ",", ".")), r)
    Selection.Object.AutoSize = True
    Selection.Left = x + w + 10
    Selection.Top = y - h / 2 - Selection.Height / 2
    ActiveCell.Activate
  Next
Next
End Sub

L'affichage de l'assemblage correspond à la ligne du double-clic dans le tableau.

Si dans le tableau au lieu de "1" on a "2", l'élément est copié 2 fois.

A+

 

[polobeg]

Re : Obtenir un schéma de principe selon un tableau

Bonjour à vous deux,

Modeste peux tu expliquer un peu comment tu as fait s'il te plait ? c'est a peut prés sa que je recherche sauf que lorsque je met deux dans une ligne l'image s'aggrandi moi je voudrais qu'une deuxieme image vienne au dessus de la premiere.

Job, je suis desolé mais j'ai regardé au code et au fichier mais cela ne fonctionne pas chez moi. Est ce normal ? ou moi qui ne sait pas utilisé ton aide.

Cordialement

 

[Modeste geedee]

Re : Obtenir un schéma de principe selon un tableau

Bonsour®
il s'agit d'un graphe avec barre empilées
comportant 14 séries ( les 14 tailles d'éléments possibles d'une combinaison)
1 série par composition (ici 5 compositions)
chaque valeur correspondant à 1 dimension d'un élément( le nombre d'éléments : Fond ,réduction , dalle doit être limité à 1)
les couleurs de remplissage sont remplacées par des textures correspondantes aux images des éléments correspondants

 

[job75]

Re : Obtenir un schéma de principe selon un tableau

Bonjour polobeg, le fil,

J'ai créé le code sur Excel 2010.

Si vous ne pouvez pas faire fonctionner le fichier du post #5 c'est qu'il y a un problème de compatibilité avec votre version Excel (2003 je suppose).

Malheureusement je n'ai pas cette version sous la main.

Il faudrait que vous m'indiquiez sur quelle instruction ça coince.

Pour ce faire testez ce fichier (2), j'ai mis la macro CopieShape dans un module standard.

A+

 

[polobeg]

Re : Obtenir un schéma de principe selon un tableau

Merci Modeste, faudra que je regarde à ça ce soir chez moi tranquillement

Job, lorsque je met un chiffre dans le tableau rien ne se passe et revanche lorsque je clique sur des des chiffre dejà mis il me met débeugage sur cette ligne ci :

Selection.Object.WordWrap = False

j'ai testé = true mais rien n'y fait

Cordialement

 

[job75]

Re : Obtenir un schéma de principe selon un tableau

Re,

J'ai modifié la manière dont est traitée la copie du Label, voyez si cela fonctionne chez vous :

Sub CopieShape(r As Range, lig, o As Object, x#, y#, titre$, der As Byte)
Dim i, h#, w#
For Each r In r
  For i = 1 To IIf(der, 1, Val(r(lig)))
    o.Copy
    Me.Paste
    Selection.Left = x
    Selection.Top = y
    h = Selection.Height
    w = Selection.Width
    y = y + h
    ActiveCell.Activate
    Me.OLEObjects("Label1").Copy
    Me.Paste
    For Each o In Me.OLEObjects 'recherche du nouveau Label
      If o.TopLeftCell.Address = ActiveCell.Address Then Exit For
    Next
    o.Object.WordWrap = False
    o.Object.AutoSize = False
    o.Object.Caption = titre & " " & _
      IIf(der, 100 * Val(Replace(r(lig), ",", ".")), r)
    o.Object.AutoSize = True
    o.Left = x + w + 10
    o.Top = y - h / 2 - o.Height / 2
  Next
Next
ActiveCell.Activate
End Sub

Fichier (3), s'il fonctionne j'ai un autre fichier, plus développé, qui vous attend...

Nota 1 : les macros sont toutes dans le code de la feuille.

Nota 2 : je vous rappelle qu'il suffit de faire un double-clic sur la ligne du tableau qui vous intéresse.

A+

 

[polobeg]

Re : Obtenir un schéma de principe selon un tableau

Non Désolé toujours rien
Seulement des LABEL1 qui apparaissent lorsque je fais un double clic

Comme vu ci-dessous dans l'imprim' écran


Cette fois ci c'est bject.WordWrap = False qui fait que cela ne fonctionne pas à priori.

Cordialement

 

[job75]

Re : Obtenir un schéma de principe selon un tableau

Re,

Ces Labels sont bien récalcitrants, nouvelle tentative dans ce fichier (4) :

Sub CopieShape(r As Range, lig, s As Shape, x#, y#, titre$, der As Byte)
Dim i, h#, w#, o As OLEObject
For Each r In r
  For i = 1 To IIf(der, 1, Val(r(lig)))
    s.Copy
    Me.Paste
    Selection.Left = x
    Selection.Top = y
    h = Selection.Height
    w = Selection.Width
    y = y + h
    Set o = Me.OLEObjects("Label1")
    o.Object.Caption = "zzz" 'repère
    o.Copy
    Me.Paste
    o.Object.Caption = "Label1"
    For Each o In Me.OLEObjects 'recherche du nouveau Label
      If o.Object.Caption = "zzz" Then Exit For
    Next
    o.Object.WordWrap = False
    o.Object.AutoSize = False
    o.Object.Caption = titre & " " & _
      IIf(der, 100 * Val(Replace(r(lig), ",", ".")), r)
    o.Object.AutoSize = True
    o.Left = x + w + 10
    o.Top = y - h / 2 - o.Height / 2
  Next
Next
ActiveCell.Activate
End Sub

A+

 

[polobeg]

Re : Obtenir un schéma de principe selon un tableau

Bonjour,

Toujours pas :/ chez vous cela fonctionne pourtant non ?

bject.Caption = "zzz" 'repère
Voici le petit souci du jour
( j'ai cherché a quoi cela pouvait correspondre mais je n'ai pas trouvé d'objet à cet effet )

EDIT : Pensant à ça, j'ai éssayé de chez moi aussi excel2007 et j'avais le meme probleme.

Cordialement

 

[job75]

Re : Obtenir un schéma de principe selon un tableau

Bonjour polobeg, le forum,

Dernière tentative avec ce fichier (5) :

- j'ai mis la propriété Locked de Label1 à False

- après chaque copier coller je réactive la cellule active par ActiveCell.Activate

- j'en profite pour mettre des marges sur hauteur et largeur en les multipliant par 1.2 :

'-----
    o.Width = 1.2 * o.Width 'pour Excel 2003
    o.Height = 1.2 * o.Height

En effet lors de votre fil sur les flèches j'avais vu sur Excel 2003 que c'était nécessaire.

Nota : c'est vraiment incroyable que chez vous on ne puisse même pas modifier la propriété Caption de Label1 alors que sur l'autre fil nous n'avons jamais eu de problème avec les Labels.

Si mon fichier ne fonctionne pas chez vous il faudrait peut être repartir sur votre fichier à vous (créé sur Excel 2003) en y mettant tout mon code et en vérifiant bien les noms des objets.

C'est peut-être en effet parce que j'ai manipulé le fichier sur Excel 2010 qu'il ne passe plus chez vous.

A+

 

[job75]

Re : Obtenir un schéma de principe selon un tableau

Re,

Bon ne nous cassons plus la tête avec des Labels, remplaçons-les par des Zones de texte.

C'est nettement plus simple :

Sub CopieShape(r As Range, lig, s As Shape, x#, y#, titre$, der As Byte)
Dim i, h#, w#
For Each r In r
  For i = 1 To IIf(der, 1, Val(r(lig)))
    s.Copy
    Me.Paste
    Selection.Left = x
    Selection.Top = y
    h = Selection.Height
    w = Selection.Width
    y = y + h
    Me.DrawingObjects("ZoneTexte 1").Copy
    Me.Paste
    Selection.Text = titre & " " & _
      IIf(der, 100 * Val(Replace(r(lig), ",", ".")), r)
    Selection.Left = x + w + 6
    Selection.Top = y - h / 2 - Selection.Height / 2
  Next
Next
ActiveCell.Activate
End Sub

Ci joint 2 fichiers, le 2ème est plus élaboré avec :

- la zone O6:O9, modifiable par double-clic, qui permet de modifier la hauteur des objets

- un cadre de bordures qui s'ajuste automatiquement

- des formules avec SOMMEPROD dans N6:N9.

A+