Interieur cellule

Le
Guy72
Bonsoir,
Si on peut séparer une cellule par une diagonale.
Alors peut on mettre une couleur différente dans les deux parties de la
cellule ?
--
Cordialement
Guy
Vidéos High-Tech et Jeu Vidéo
Téléchargements
Vos réponses Page 1 / 2
Gagnez chaque mois un abonnement Premium avec GNT : Inscrivez-vous !
Trier par : date / pertinence
JB
Le #7061951
Bonjour,

Sub CreeShapes()
Set c = Range("B2")
With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Heig ht)
.Fill.ForeColor.RGB = RGB(255, 0, 0)
.Line.ForeColor.RGB = RGB(255, 0, 0)
.IncrementRotation 180
End With
With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Heig ht)
.Fill.ForeColor.RGB = RGB(0, 255, 0)
.Line.ForeColor.RGB = RGB(0, 255, 0)
End With
End Sub

Sub supshapes()
Sheets(1).DrawingObjects.Delete
End Sub

http://cjoint.com/?gviUKoFRfU

JB
http://boisgontierjacques.free.fr/


On 21 juin, 00:40, "Guy72"
Bonsoir,
Si on peut séparer une cellule par une diagonale.
Alors peut on mettre une couleur différente dans les deux parties de la
cellule ?
--
Cordialement
Guy


JB
Le #7062141
Avec texte:

Sub CreeShapes()
Set c = Range("B2")
With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Heig ht)
.OLEFormat.Object.Characters.Text = "Texte"
.OLEFormat.Object.Characters.Font.Size = 7
.Fill.ForeColor.RGB = RGB(255, 0, 0)
.Line.ForeColor.RGB = RGB(255, 0, 0)
.IncrementRotation 180
End With
With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Heig ht)
.OLEFormat.Object.Characters.Text = "Texte"
.OLEFormat.Object.Characters.Font.Size = 7
.Fill.ForeColor.RGB = RGB(0, 255, 0)
.Line.ForeColor.RGB = RGB(0, 255, 0)
End With
End Sub

Sub supshapes()
Sheets(1).DrawingObjects.Delete
End Sub

JB

On 21 juin, 08:46, JB
Bonjour,

Sub CreeShapes()
     Set c = Range("B2")
     With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle , _
       Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height :=c.Height)
        .Fill.ForeColor.RGB = RGB(255, 0, 0)
        .Line.ForeColor.RGB = RGB(255, 0, 0)
        .IncrementRotation 180
      End With
      With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangl e, _
       Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height :=c.Height)
        .Fill.ForeColor.RGB = RGB(0, 255, 0)
        .Line.ForeColor.RGB = RGB(0, 255, 0)
      End With
End Sub

Sub supshapes()
   Sheets(1).DrawingObjects.Delete
End Sub

http://cjoint.com/?gviUKoFRfU

JBhttp://boisgontierjacques.free.fr/

On 21 juin, 00:40, "Guy72"


> Bonsoir,
> Si on peut séparer une cellule par une diagonale.
> Alors peut on mettre une couleur différente dans les deux parties de la
> cellule ?
> --
> Cordialement
> Guy- Masquer le texte des messages précédents -

- Afficher le texte des messages précédents -


Guy72
Le #7062721
Bonjour JB
Merci.
Par contre, j'ai l'intention de faire cette opération dans pas mal de
cellules.
comment je peux faire sans avoir à remplacer la cellule B2 à chaque fois ?
Ou de faire une copie aussi à chaque fois ?
--
Cordialement
Guy

"JB"
Avec texte:

Sub CreeShapes()
Set c = Range("B2")
With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Height)
.OLEFormat.Object.Characters.Text = "Texte"
.OLEFormat.Object.Characters.Font.Size = 7
.Fill.ForeColor.RGB = RGB(255, 0, 0)
.Line.ForeColor.RGB = RGB(255, 0, 0)
.IncrementRotation 180
End With
With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Height)
.OLEFormat.Object.Characters.Text = "Texte"
.OLEFormat.Object.Characters.Font.Size = 7
.Fill.ForeColor.RGB = RGB(0, 255, 0)
.Line.ForeColor.RGB = RGB(0, 255, 0)
End With
End Sub

Sub supshapes()
Sheets(1).DrawingObjects.Delete
End Sub

JB

On 21 juin, 08:46, JB
Bonjour,

Sub CreeShapes()
Set c = Range("B2")
With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Height)
.Fill.ForeColor.RGB = RGB(255, 0, 0)
.Line.ForeColor.RGB = RGB(255, 0, 0)
.IncrementRotation 180
End With
With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Height)
.Fill.ForeColor.RGB = RGB(0, 255, 0)
.Line.ForeColor.RGB = RGB(0, 255, 0)
End With
End Sub

Sub supshapes()
Sheets(1).DrawingObjects.Delete
End Sub

http://cjoint.com/?gviUKoFRfU

JBhttp://boisgontierjacques.free.fr/

On 21 juin, 00:40, "Guy72"


> Bonsoir,
> Si on peut séparer une cellule par une diagonale.
> Alors peut on mettre une couleur différente dans les deux parties de la
> cellule ?
> --
> Cordialement
> Guy- Masquer le texte des messages précédents -

- Afficher le texte des messages précédents -


JB
Le #7063381
Sub essai()
CreeShapes Range("B2"), "texte1", "texte2"
CreeShapes Range("E3"), "texte3", "texte4"
End Sub

Sub CreeShapes(c, texte1, texte2)
With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Heig ht)
.OLEFormat.Object.Characters.Text = texte1
.OLEFormat.Object.Characters.Font.Size = 7
.Fill.ForeColor.RGB = RGB(255, 0, 0)
.Line.ForeColor.RGB = RGB(255, 0, 0)
.IncrementRotation 180
End With
With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Heig ht)
.OLEFormat.Object.Characters.Text = texte2
.OLEFormat.Object.Characters.Font.Size = 7
.Fill.ForeColor.RGB = RGB(0, 255, 0)
.Line.ForeColor.RGB = RGB(0, 255, 0)
End With
End Sub

Sub supshapes()
Sheets(1).DrawingObjects.Delete
End Sub

http://cjoint.com/?gvlK2hGqxe

JB

On 21 juin, 10:08, "Guy72"
Bonjour JB
Merci.
Par contre, j'ai l'intention de faire cette opération dans pas mal de
cellules.
comment je peux faire sans avoir à remplacer la cellule B2 à chaque f ois ?
Ou de faire une copie aussi à chaque fois ?
--
Cordialement
Guy

"JB"
Avec texte:

Sub CreeShapes()
     Set c = Range("B2")
     With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle , _
       Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height :=c.Height)
        .OLEFormat.Object.Characters.Text = "Texte"
        .OLEFormat.Object.Characters.Font.Size = 7
        .Fill.ForeColor.RGB = RGB(255, 0, 0)
        .Line.ForeColor.RGB = RGB(255, 0, 0)
        .IncrementRotation 180
      End With
      With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangl e, _
       Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height :=c.Height)
        .OLEFormat.Object.Characters.Text = "Texte"
        .OLEFormat.Object.Characters.Font.Size = 7
        .Fill.ForeColor.RGB = RGB(0, 255, 0)
        .Line.ForeColor.RGB = RGB(0, 255, 0)
      End With
End Sub

Sub supshapes()
   Sheets(1).DrawingObjects.Delete
End Sub

JB

On 21 juin, 08:46, JB


> Bonjour,

> Sub CreeShapes()
> Set c = Range("B2")
> With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
> Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Height)
> .Fill.ForeColor.RGB = RGB(255, 0, 0)
> .Line.ForeColor.RGB = RGB(255, 0, 0)
> .IncrementRotation 180
> End With
> With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
> Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Height)
> .Fill.ForeColor.RGB = RGB(0, 255, 0)
> .Line.ForeColor.RGB = RGB(0, 255, 0)
> End With
> End Sub

> Sub supshapes()
> Sheets(1).DrawingObjects.Delete
> End Sub

>http://cjoint.com/?gviUKoFRfU

> JBhttp://boisgontierjacques.free.fr/

> On 21 juin, 00:40, "Guy72"
> > Bonsoir,
> > Si on peut séparer une cellule par une diagonale.
> > Alors peut on mettre une couleur différente dans les deux parties d e la
> > cellule ?
> > --
> > Cordialement
> > Guy- Masquer le texte des messages précédents -

> - Afficher le texte des messages précédents -- Masquer le texte des messages précédents -

- Afficher le texte des messages précédents -


JB
Le #7064381
Sub essai()
CreeShapes Range("B2"), "texte1", "texte2"
CreeShapes Range("E3"), "texte3", "texte4"
End Sub

Sub CreeShapes(c, texte1, texte2)
On Error Resume Next
ActiveSheet.Shapes(c.Address & "1").Delete
ActiveSheet.Shapes(c.Address & "2").Delete
With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Heig ht)
.OLEFormat.Object.Characters.Text = texte1
.OLEFormat.Object.Characters.Font.Size = 7
.Fill.ForeColor.RGB = RGB(255, 0, 0)
.Line.ForeColor.RGB = RGB(255, 0, 0)
.IncrementRotation 180
.Name = c.Address & "1"
End With
With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Heig ht)
.OLEFormat.Object.Characters.Text = texte2
.OLEFormat.Object.Characters.Font.Size = 7
.Fill.ForeColor.RGB = RGB(0, 255, 0)
.Line.ForeColor.RGB = RGB(0, 255, 0)
.Name = c.Address & "2"
End With
End Sub

Sub supshapes()
Sheets(1).DrawingObjects.Delete
End Sub


On 21 juin, 11:36, JB
Sub essai()
  CreeShapes Range("B2"), "texte1", "texte2"
  CreeShapes Range("E3"), "texte3", "texte4"
End Sub

Sub CreeShapes(c, texte1, texte2)
     With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle , _
       Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height :=c.Height)
        .OLEFormat.Object.Characters.Text = texte1
        .OLEFormat.Object.Characters.Font.Size = 7
        .Fill.ForeColor.RGB = RGB(255, 0, 0)
        .Line.ForeColor.RGB = RGB(255, 0, 0)
        .IncrementRotation 180
      End With
      With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangl e, _
       Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height :=c.Height)
        .OLEFormat.Object.Characters.Text = texte2
        .OLEFormat.Object.Characters.Font.Size = 7
        .Fill.ForeColor.RGB = RGB(0, 255, 0)
        .Line.ForeColor.RGB = RGB(0, 255, 0)
      End With
End Sub

Sub supshapes()
   Sheets(1).DrawingObjects.Delete
End Sub

http://cjoint.com/?gvlK2hGqxe

JB

On 21 juin, 10:08, "Guy72"


> Bonjour JB
> Merci.
> Par contre, j'ai l'intention de faire cette opération dans pas mal de
> cellules.
> comment je peux faire sans avoir à remplacer la cellule B2 à chaque fois ?
> Ou de faire une copie aussi à chaque fois ?
> --
> Cordialement
> Guy

> "JB" >
> Avec texte:

> Sub CreeShapes()
>      Set c = Range("B2")
>      With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriang le, _
>        Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Heig ht:=c.Height)
>         .OLEFormat.Object.Characters.Text = "Texte"
>         .OLEFormat.Object.Characters.Font.Size = 7
>         .Fill.ForeColor.RGB = RGB(255, 0, 0)
>         .Line.ForeColor.RGB = RGB(255, 0, 0)
>         .IncrementRotation 180
>       End With
>       With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTrian gle, _
>        Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Heig ht:=c.Height)
>         .OLEFormat.Object.Characters.Text = "Texte"
>         .OLEFormat.Object.Characters.Font.Size = 7
>         .Fill.ForeColor.RGB = RGB(0, 255, 0)
>         .Line.ForeColor.RGB = RGB(0, 255, 0)
>       End With
> End Sub

> Sub supshapes()
>    Sheets(1).DrawingObjects.Delete
> End Sub

> JB

> On 21 juin, 08:46, JB
> > Bonjour,

> > Sub CreeShapes()
> > Set c = Range("B2")
> > With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
> > Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Heigh t)
> > .Fill.ForeColor.RGB = RGB(255, 0, 0)
> > .Line.ForeColor.RGB = RGB(255, 0, 0)
> > .IncrementRotation 180
> > End With
> > With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
> > Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Heigh t)
> > .Fill.ForeColor.RGB = RGB(0, 255, 0)
> > .Line.ForeColor.RGB = RGB(0, 255, 0)
> > End With
> > End Sub

> > Sub supshapes()
> > Sheets(1).DrawingObjects.Delete
> > End Sub

> >http://cjoint.com/?gviUKoFRfU

> > JBhttp://boisgontierjacques.free.fr/

> > On 21 juin, 00:40, "Guy72"
> > > Bonsoir,
> > > Si on peut séparer une cellule par une diagonale.
> > > Alors peut on mettre une couleur différente dans les deux parties de la
> > > cellule ?
> > > --
> > > Cordialement
> > > Guy- Masquer le texte des messages précédents -

> > - Afficher le texte des messages précédents -- Masquer le texte d es messages précédents -

> - Afficher le texte des messages précédents -- Masquer le texte des messages précédents -

- Afficher le texte des messages précédents -


Guy72
Le #7065141
Oui je comprend, il suffit que je mette le N° de cellule dans le code de la
macros, mais ce ne seras pas toujours les même cellules.
Ce qu'il faudrait, quand je sélectionne par exemple : les cellules
C3....D8....E7....etc.
Avec un bouton, je puisse effectuer la macro dans les cellule sélectionnées.
--
Cordialement
Guy

"JB"
Sub essai()
CreeShapes Range("B2"), "texte1", "texte2"
CreeShapes Range("E3"), "texte3", "texte4"
End Sub

Sub CreeShapes(c, texte1, texte2)
On Error Resume Next
ActiveSheet.Shapes(c.Address & "1").Delete
ActiveSheet.Shapes(c.Address & "2").Delete
With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Height)
.OLEFormat.Object.Characters.Text = texte1
.OLEFormat.Object.Characters.Font.Size = 7
.Fill.ForeColor.RGB = RGB(255, 0, 0)
.Line.ForeColor.RGB = RGB(255, 0, 0)
.IncrementRotation 180
.Name = c.Address & "1"
End With
With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Height)
.OLEFormat.Object.Characters.Text = texte2
.OLEFormat.Object.Characters.Font.Size = 7
.Fill.ForeColor.RGB = RGB(0, 255, 0)
.Line.ForeColor.RGB = RGB(0, 255, 0)
.Name = c.Address & "2"
End With
End Sub

Sub supshapes()
Sheets(1).DrawingObjects.Delete
End Sub


On 21 juin, 11:36, JB
Sub essai()
CreeShapes Range("B2"), "texte1", "texte2"
CreeShapes Range("E3"), "texte3", "texte4"
End Sub

Sub CreeShapes(c, texte1, texte2)
With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Height)
.OLEFormat.Object.Characters.Text = texte1
.OLEFormat.Object.Characters.Font.Size = 7
.Fill.ForeColor.RGB = RGB(255, 0, 0)
.Line.ForeColor.RGB = RGB(255, 0, 0)
.IncrementRotation 180
End With
With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Height)
.OLEFormat.Object.Characters.Text = texte2
.OLEFormat.Object.Characters.Font.Size = 7
.Fill.ForeColor.RGB = RGB(0, 255, 0)
.Line.ForeColor.RGB = RGB(0, 255, 0)
End With
End Sub

Sub supshapes()
Sheets(1).DrawingObjects.Delete
End Sub

http://cjoint.com/?gvlK2hGqxe

JB

On 21 juin, 10:08, "Guy72"


> Bonjour JB
> Merci.
> Par contre, j'ai l'intention de faire cette opération dans pas mal de
> cellules.
> comment je peux faire sans avoir à remplacer la cellule B2 à chaque fois
> ?
> Ou de faire une copie aussi à chaque fois ?
> --
> Cordialement
> Guy

> "JB" >
> Avec texte:

> Sub CreeShapes()
> Set c = Range("B2")
> With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
> Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Height)
> .OLEFormat.Object.Characters.Text = "Texte"
> .OLEFormat.Object.Characters.Font.Size = 7
> .Fill.ForeColor.RGB = RGB(255, 0, 0)
> .Line.ForeColor.RGB = RGB(255, 0, 0)
> .IncrementRotation 180
> End With
> With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
> Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Height)
> .OLEFormat.Object.Characters.Text = "Texte"
> .OLEFormat.Object.Characters.Font.Size = 7
> .Fill.ForeColor.RGB = RGB(0, 255, 0)
> .Line.ForeColor.RGB = RGB(0, 255, 0)
> End With
> End Sub

> Sub supshapes()
> Sheets(1).DrawingObjects.Delete
> End Sub

> JB

> On 21 juin, 08:46, JB
> > Bonjour,

> > Sub CreeShapes()
> > Set c = Range("B2")
> > With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
> > Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Height)
> > .Fill.ForeColor.RGB = RGB(255, 0, 0)
> > .Line.ForeColor.RGB = RGB(255, 0, 0)
> > .IncrementRotation 180
> > End With
> > With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
> > Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Height)
> > .Fill.ForeColor.RGB = RGB(0, 255, 0)
> > .Line.ForeColor.RGB = RGB(0, 255, 0)
> > End With
> > End Sub

> > Sub supshapes()
> > Sheets(1).DrawingObjects.Delete
> > End Sub

> >http://cjoint.com/?gviUKoFRfU

> > JBhttp://boisgontierjacques.free.fr/

> > On 21 juin, 00:40, "Guy72"
> > > Bonsoir,
> > > Si on peut séparer une cellule par une diagonale.
> > > Alors peut on mettre une couleur différente dans les deux parties de
> > > la
> > > cellule ?
> > > --
> > > Cordialement
> > > Guy- Masquer le texte des messages précédents -

> > - Afficher le texte des messages précédents -- Masquer le texte des
> > messages précédents -

> - Afficher le texte des messages précédents -- Masquer le texte des
> messages précédents -

- Afficher le texte des messages précédents -


JB
Le #7065401
Sub essai2()
For Each c In Selection
CreeShapes c, "texte1", "texte2"
Next c
End Sub

Sub CreeShapes(c, texte1, texte2)
On Error Resume Next
ActiveSheet.Shapes(c.Address & "1").Delete
ActiveSheet.Shapes(c.Address & "2").Delete
With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Heig ht)
.OLEFormat.Object.Characters.Text = texte1
.OLEFormat.Object.Characters.Font.Size = 7
.Fill.ForeColor.RGB = RGB(255, 0, 0)
.Line.ForeColor.RGB = RGB(255, 0, 0)
.IncrementRotation 180
.Name = c.Address & "1"
End With
With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Heig ht)
.OLEFormat.Object.Characters.Text = texte2
.OLEFormat.Object.Characters.Font.Size = 7
.Fill.ForeColor.RGB = RGB(0, 255, 0)
.Line.ForeColor.RGB = RGB(0, 255, 0)
.Name = c.Address & "2"
End With
End Sub

Sub supshapes()
For Each c In ActiveSheet.Shapes
If c.Type = 1 Then c.Delete
Next c
End Sub

http://cjoint.com/?gvp1rRz2wn

JB

On 21 juin, 15:07, "Guy72"
Oui je comprend, il suffit que je mette le N° de cellule dans le code d e la
macros, mais ce ne seras pas toujours les même cellules.
Ce qu'il faudrait, quand je sélectionne par exemple : les cellules
C3....D8....E7....etc.
Avec un bouton, je puisse effectuer la macro dans les cellule sélection nées.
--
Cordialement
Guy

"JB"
Sub essai()
  CreeShapes Range("B2"), "texte1", "texte2"
  CreeShapes Range("E3"), "texte3", "texte4"
End Sub

Sub CreeShapes(c, texte1, texte2)
     On Error Resume Next
     ActiveSheet.Shapes(c.Address & "1").Delete
     ActiveSheet.Shapes(c.Address & "2").Delete
     With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle , _
       Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height :=c.Height)
        .OLEFormat.Object.Characters.Text = texte1
        .OLEFormat.Object.Characters.Font.Size = 7
        .Fill.ForeColor.RGB = RGB(255, 0, 0)
        .Line.ForeColor.RGB = RGB(255, 0, 0)
        .IncrementRotation 180
        .Name = c.Address & "1"
      End With
      With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangl e, _
       Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height :=c.Height)
        .OLEFormat.Object.Characters.Text = texte2
        .OLEFormat.Object.Characters.Font.Size = 7
        .Fill.ForeColor.RGB = RGB(0, 255, 0)
        .Line.ForeColor.RGB = RGB(0, 255, 0)
        .Name = c.Address & "2"
      End With
End Sub

Sub supshapes()
   Sheets(1).DrawingObjects.Delete
End Sub

On 21 juin, 11:36, JB


> Sub essai()
> CreeShapes Range("B2"), "texte1", "texte2"
> CreeShapes Range("E3"), "texte3", "texte4"
> End Sub

> Sub CreeShapes(c, texte1, texte2)
> With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
> Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Height)
> .OLEFormat.Object.Characters.Text = texte1
> .OLEFormat.Object.Characters.Font.Size = 7
> .Fill.ForeColor.RGB = RGB(255, 0, 0)
> .Line.ForeColor.RGB = RGB(255, 0, 0)
> .IncrementRotation 180
> End With
> With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
> Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Height)
> .OLEFormat.Object.Characters.Text = texte2
> .OLEFormat.Object.Characters.Font.Size = 7
> .Fill.ForeColor.RGB = RGB(0, 255, 0)
> .Line.ForeColor.RGB = RGB(0, 255, 0)
> End With
> End Sub

> Sub supshapes()
> Sheets(1).DrawingObjects.Delete
> End Sub

>http://cjoint.com/?gvlK2hGqxe

> JB

> On 21 juin, 10:08, "Guy72"
> > Bonjour JB
> > Merci.
> > Par contre, j'ai l'intention de faire cette opération dans pas mal de
> > cellules.
> > comment je peux faire sans avoir à remplacer la cellule B2 à chaq ue fois
> > ?
> > Ou de faire une copie aussi à chaque fois ?
> > --
> > Cordialement
> > Guy

> > "JB" > >
> > Avec texte:

> > Sub CreeShapes()
> > Set c = Range("B2")
> > With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
> > Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Heigh t)
> > .OLEFormat.Object.Characters.Text = "Texte"
> > .OLEFormat.Object.Characters.Font.Size = 7
> > .Fill.ForeColor.RGB = RGB(255, 0, 0)
> > .Line.ForeColor.RGB = RGB(255, 0, 0)
> > .IncrementRotation 180
> > End With
> > With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
> > Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Heigh t)
> > .OLEFormat.Object.Characters.Text = "Texte"
> > .OLEFormat.Object.Characters.Font.Size = 7
> > .Fill.ForeColor.RGB = RGB(0, 255, 0)
> > .Line.ForeColor.RGB = RGB(0, 255, 0)
> > End With
> > End Sub

> > Sub supshapes()
> > Sheets(1).DrawingObjects.Delete
> > End Sub

> > JB

> > On 21 juin, 08:46, JB
> > > Bonjour,

> > > Sub CreeShapes()
> > > Set c = Range("B2")
> > > With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
> > > Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Hei ght)
> > > .Fill.ForeColor.RGB = RGB(255, 0, 0)
> > > .Line.ForeColor.RGB = RGB(255, 0, 0)
> > > .IncrementRotation 180
> > > End With
> > > With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
> > > Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Hei ght)
> > > .Fill.ForeColor.RGB = RGB(0, 255, 0)
> > > .Line.ForeColor.RGB = RGB(0, 255, 0)
> > > End With
> > > End Sub

> > > Sub supshapes()
> > > Sheets(1).DrawingObjects.Delete
> > > End Sub

> > >http://cjoint.com/?gviUKoFRfU

> > > JBhttp://boisgontierjacques.free.fr/

> > > On 21 juin, 00:40, "Guy72"
> > > > Bonsoir,
> > > > Si on peut séparer une cellule par une diagonale.
> > > > Alors peut on mettre une couleur différente dans les deux parti es de
> > > > la
> > > > cellule ?
> > > > --
> > > > Cordialement
> > > > Guy- Masquer le texte des messages précédents -

> > > - Afficher le texte des messages précédents -- Masquer le texte des
> > > messages précédents -

> > - Afficher le texte des messages précédents -- Masquer le texte d es
> > messages précédents -

> - Afficher le texte des messages précédents -- Masquer le texte des messages précédents -

- Afficher le texte des messages précédents -


Guy72
Le #7065491
OK, Merci encore JB
--
Cordialement
Guy

"JB"

Sub essai2()
For Each c In Selection
CreeShapes c, "texte1", "texte2"
Next c
End Sub

Sub CreeShapes(c, texte1, texte2)
On Error Resume Next
ActiveSheet.Shapes(c.Address & "1").Delete
ActiveSheet.Shapes(c.Address & "2").Delete
With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Height)
.OLEFormat.Object.Characters.Text = texte1
.OLEFormat.Object.Characters.Font.Size = 7
.Fill.ForeColor.RGB = RGB(255, 0, 0)
.Line.ForeColor.RGB = RGB(255, 0, 0)
.IncrementRotation 180
.Name = c.Address & "1"
End With
With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Height)
.OLEFormat.Object.Characters.Text = texte2
.OLEFormat.Object.Characters.Font.Size = 7
.Fill.ForeColor.RGB = RGB(0, 255, 0)
.Line.ForeColor.RGB = RGB(0, 255, 0)
.Name = c.Address & "2"
End With
End Sub

Sub supshapes()
For Each c In ActiveSheet.Shapes
If c.Type = 1 Then c.Delete
Next c
End Sub

http://cjoint.com/?gvp1rRz2wn

JB

On 21 juin, 15:07, "Guy72"
Oui je comprend, il suffit que je mette le N° de cellule dans le code de
la
macros, mais ce ne seras pas toujours les même cellules.
Ce qu'il faudrait, quand je sélectionne par exemple : les cellules
C3....D8....E7....etc.
Avec un bouton, je puisse effectuer la macro dans les cellule
sélectionnées.
--
Cordialement
Guy

"JB"
Sub essai()
CreeShapes Range("B2"), "texte1", "texte2"
CreeShapes Range("E3"), "texte3", "texte4"
End Sub

Sub CreeShapes(c, texte1, texte2)
On Error Resume Next
ActiveSheet.Shapes(c.Address & "1").Delete
ActiveSheet.Shapes(c.Address & "2").Delete
With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Height)
.OLEFormat.Object.Characters.Text = texte1
.OLEFormat.Object.Characters.Font.Size = 7
.Fill.ForeColor.RGB = RGB(255, 0, 0)
.Line.ForeColor.RGB = RGB(255, 0, 0)
.IncrementRotation 180
.Name = c.Address & "1"
End With
With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Height)
.OLEFormat.Object.Characters.Text = texte2
.OLEFormat.Object.Characters.Font.Size = 7
.Fill.ForeColor.RGB = RGB(0, 255, 0)
.Line.ForeColor.RGB = RGB(0, 255, 0)
.Name = c.Address & "2"
End With
End Sub

Sub supshapes()
Sheets(1).DrawingObjects.Delete
End Sub

On 21 juin, 11:36, JB


> Sub essai()
> CreeShapes Range("B2"), "texte1", "texte2"
> CreeShapes Range("E3"), "texte3", "texte4"
> End Sub

> Sub CreeShapes(c, texte1, texte2)
> With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
> Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Height)
> .OLEFormat.Object.Characters.Text = texte1
> .OLEFormat.Object.Characters.Font.Size = 7
> .Fill.ForeColor.RGB = RGB(255, 0, 0)
> .Line.ForeColor.RGB = RGB(255, 0, 0)
> .IncrementRotation 180
> End With
> With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
> Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Height)
> .OLEFormat.Object.Characters.Text = texte2
> .OLEFormat.Object.Characters.Font.Size = 7
> .Fill.ForeColor.RGB = RGB(0, 255, 0)
> .Line.ForeColor.RGB = RGB(0, 255, 0)
> End With
> End Sub

> Sub supshapes()
> Sheets(1).DrawingObjects.Delete
> End Sub

>http://cjoint.com/?gvlK2hGqxe

> JB

> On 21 juin, 10:08, "Guy72"
> > Bonjour JB
> > Merci.
> > Par contre, j'ai l'intention de faire cette opération dans pas mal de
> > cellules.
> > comment je peux faire sans avoir à remplacer la cellule B2 à chaque
> > fois
> > ?
> > Ou de faire une copie aussi à chaque fois ?
> > --
> > Cordialement
> > Guy

> > "JB" > >
> > Avec texte:

> > Sub CreeShapes()
> > Set c = Range("B2")
> > With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
> > Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Height)
> > .OLEFormat.Object.Characters.Text = "Texte"
> > .OLEFormat.Object.Characters.Font.Size = 7
> > .Fill.ForeColor.RGB = RGB(255, 0, 0)
> > .Line.ForeColor.RGB = RGB(255, 0, 0)
> > .IncrementRotation 180
> > End With
> > With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
> > Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Height)
> > .OLEFormat.Object.Characters.Text = "Texte"
> > .OLEFormat.Object.Characters.Font.Size = 7
> > .Fill.ForeColor.RGB = RGB(0, 255, 0)
> > .Line.ForeColor.RGB = RGB(0, 255, 0)
> > End With
> > End Sub

> > Sub supshapes()
> > Sheets(1).DrawingObjects.Delete
> > End Sub

> > JB

> > On 21 juin, 08:46, JB
> > > Bonjour,

> > > Sub CreeShapes()
> > > Set c = Range("B2")
> > > With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
> > > Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Height)
> > > .Fill.ForeColor.RGB = RGB(255, 0, 0)
> > > .Line.ForeColor.RGB = RGB(255, 0, 0)
> > > .IncrementRotation 180
> > > End With
> > > With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
> > > Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Height)
> > > .Fill.ForeColor.RGB = RGB(0, 255, 0)
> > > .Line.ForeColor.RGB = RGB(0, 255, 0)
> > > End With
> > > End Sub

> > > Sub supshapes()
> > > Sheets(1).DrawingObjects.Delete
> > > End Sub

> > >http://cjoint.com/?gviUKoFRfU

> > > JBhttp://boisgontierjacques.free.fr/

> > > On 21 juin, 00:40, "Guy72"
> > > > Bonsoir,
> > > > Si on peut séparer une cellule par une diagonale.
> > > > Alors peut on mettre une couleur différente dans les deux parties
> > > > de
> > > > la
> > > > cellule ?
> > > > --
> > > > Cordialement
> > > > Guy- Masquer le texte des messages précédents -

> > > - Afficher le texte des messages précédents -- Masquer le texte des
> > > messages précédents -

> > - Afficher le texte des messages précédents -- Masquer le texte des
> > messages précédents -

> - Afficher le texte des messages précédents -- Masquer le texte des
> messages précédents -

- Afficher le texte des messages précédents -


Guy72
Le #7066591
J'ai essayer des modifications, mais je n'y arrive, j'abandonne, j'ai besoin
encore de ton aide.
Comment obtenir la sélection avec les macros "Bleu et Miroir"

http://cjoint.com/?gvsMecA0m0
--
Cordialement
Guy

"JB"

Sub essai2()
For Each c In Selection
CreeShapes c, "texte1", "texte2"
Next c
End Sub

Sub CreeShapes(c, texte1, texte2)
On Error Resume Next
ActiveSheet.Shapes(c.Address & "1").Delete
ActiveSheet.Shapes(c.Address & "2").Delete
With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Height)
.OLEFormat.Object.Characters.Text = texte1
.OLEFormat.Object.Characters.Font.Size = 7
.Fill.ForeColor.RGB = RGB(255, 0, 0)
.Line.ForeColor.RGB = RGB(255, 0, 0)
.IncrementRotation 180
.Name = c.Address & "1"
End With
With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Height)
.OLEFormat.Object.Characters.Text = texte2
.OLEFormat.Object.Characters.Font.Size = 7
.Fill.ForeColor.RGB = RGB(0, 255, 0)
.Line.ForeColor.RGB = RGB(0, 255, 0)
.Name = c.Address & "2"
End With
End Sub

Sub supshapes()
For Each c In ActiveSheet.Shapes
If c.Type = 1 Then c.Delete
Next c
End Sub

http://cjoint.com/?gvp1rRz2wn

JB

On 21 juin, 15:07, "Guy72"
Oui je comprend, il suffit que je mette le N° de cellule dans le code de
la
macros, mais ce ne seras pas toujours les même cellules.
Ce qu'il faudrait, quand je sélectionne par exemple : les cellules
C3....D8....E7....etc.
Avec un bouton, je puisse effectuer la macro dans les cellule
sélectionnées.
--
Cordialement
Guy

"JB"
Sub essai()
CreeShapes Range("B2"), "texte1", "texte2"
CreeShapes Range("E3"), "texte3", "texte4"
End Sub

Sub CreeShapes(c, texte1, texte2)
On Error Resume Next
ActiveSheet.Shapes(c.Address & "1").Delete
ActiveSheet.Shapes(c.Address & "2").Delete
With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Height)
.OLEFormat.Object.Characters.Text = texte1
.OLEFormat.Object.Characters.Font.Size = 7
.Fill.ForeColor.RGB = RGB(255, 0, 0)
.Line.ForeColor.RGB = RGB(255, 0, 0)
.IncrementRotation 180
.Name = c.Address & "1"
End With
With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Height)
.OLEFormat.Object.Characters.Text = texte2
.OLEFormat.Object.Characters.Font.Size = 7
.Fill.ForeColor.RGB = RGB(0, 255, 0)
.Line.ForeColor.RGB = RGB(0, 255, 0)
.Name = c.Address & "2"
End With
End Sub

Sub supshapes()
Sheets(1).DrawingObjects.Delete
End Sub

On 21 juin, 11:36, JB


> Sub essai()
> CreeShapes Range("B2"), "texte1", "texte2"
> CreeShapes Range("E3"), "texte3", "texte4"
> End Sub

> Sub CreeShapes(c, texte1, texte2)
> With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
> Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Height)
> .OLEFormat.Object.Characters.Text = texte1
> .OLEFormat.Object.Characters.Font.Size = 7
> .Fill.ForeColor.RGB = RGB(255, 0, 0)
> .Line.ForeColor.RGB = RGB(255, 0, 0)
> .IncrementRotation 180
> End With
> With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
> Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Height)
> .OLEFormat.Object.Characters.Text = texte2
> .OLEFormat.Object.Characters.Font.Size = 7
> .Fill.ForeColor.RGB = RGB(0, 255, 0)
> .Line.ForeColor.RGB = RGB(0, 255, 0)
> End With
> End Sub

> Sub supshapes()
> Sheets(1).DrawingObjects.Delete
> End Sub

>http://cjoint.com/?gvlK2hGqxe

> JB

> On 21 juin, 10:08, "Guy72"
> > Bonjour JB
> > Merci.
> > Par contre, j'ai l'intention de faire cette opération dans pas mal de
> > cellules.
> > comment je peux faire sans avoir à remplacer la cellule B2 à chaque
> > fois
> > ?
> > Ou de faire une copie aussi à chaque fois ?
> > --
> > Cordialement
> > Guy

> > "JB" > >
> > Avec texte:

> > Sub CreeShapes()
> > Set c = Range("B2")
> > With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
> > Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Height)
> > .OLEFormat.Object.Characters.Text = "Texte"
> > .OLEFormat.Object.Characters.Font.Size = 7
> > .Fill.ForeColor.RGB = RGB(255, 0, 0)
> > .Line.ForeColor.RGB = RGB(255, 0, 0)
> > .IncrementRotation 180
> > End With
> > With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
> > Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Height)
> > .OLEFormat.Object.Characters.Text = "Texte"
> > .OLEFormat.Object.Characters.Font.Size = 7
> > .Fill.ForeColor.RGB = RGB(0, 255, 0)
> > .Line.ForeColor.RGB = RGB(0, 255, 0)
> > End With
> > End Sub

> > Sub supshapes()
> > Sheets(1).DrawingObjects.Delete
> > End Sub

> > JB

> > On 21 juin, 08:46, JB
> > > Bonjour,

> > > Sub CreeShapes()
> > > Set c = Range("B2")
> > > With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
> > > Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Height)
> > > .Fill.ForeColor.RGB = RGB(255, 0, 0)
> > > .Line.ForeColor.RGB = RGB(255, 0, 0)
> > > .IncrementRotation 180
> > > End With
> > > With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
> > > Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Height)
> > > .Fill.ForeColor.RGB = RGB(0, 255, 0)
> > > .Line.ForeColor.RGB = RGB(0, 255, 0)
> > > End With
> > > End Sub

> > > Sub supshapes()
> > > Sheets(1).DrawingObjects.Delete
> > > End Sub

> > >http://cjoint.com/?gviUKoFRfU

> > > JBhttp://boisgontierjacques.free.fr/

> > > On 21 juin, 00:40, "Guy72"
> > > > Bonsoir,
> > > > Si on peut séparer une cellule par une diagonale.
> > > > Alors peut on mettre une couleur différente dans les deux parties
> > > > de
> > > > la
> > > > cellule ?
> > > > --
> > > > Cordialement
> > > > Guy- Masquer le texte des messages précédents -

> > > - Afficher le texte des messages précédents -- Masquer le texte des
> > > messages précédents -

> > - Afficher le texte des messages précédents -- Masquer le texte des
> > messages précédents -

> - Afficher le texte des messages précédents -- Masquer le texte des
> messages précédents -

- Afficher le texte des messages précédents -


Guy72
Le #7066831
J'ai réussi à faire "Miroir" mais pas "Bleu (sur deux cellules)
http://cjoint.com/?gvtog0pYJa
--
Cordialement
Guy

"JB"

Sub essai2()
For Each c In Selection
CreeShapes c, "texte1", "texte2"
Next c
End Sub

Sub CreeShapes(c, texte1, texte2)
On Error Resume Next
ActiveSheet.Shapes(c.Address & "1").Delete
ActiveSheet.Shapes(c.Address & "2").Delete
With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Height)
.OLEFormat.Object.Characters.Text = texte1
.OLEFormat.Object.Characters.Font.Size = 7
.Fill.ForeColor.RGB = RGB(255, 0, 0)
.Line.ForeColor.RGB = RGB(255, 0, 0)
.IncrementRotation 180
.Name = c.Address & "1"
End With
With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Height)
.OLEFormat.Object.Characters.Text = texte2
.OLEFormat.Object.Characters.Font.Size = 7
.Fill.ForeColor.RGB = RGB(0, 255, 0)
.Line.ForeColor.RGB = RGB(0, 255, 0)
.Name = c.Address & "2"
End With
End Sub

Sub supshapes()
For Each c In ActiveSheet.Shapes
If c.Type = 1 Then c.Delete
Next c
End Sub

http://cjoint.com/?gvp1rRz2wn

JB

On 21 juin, 15:07, "Guy72"
Oui je comprend, il suffit que je mette le N° de cellule dans le code de
la
macros, mais ce ne seras pas toujours les même cellules.
Ce qu'il faudrait, quand je sélectionne par exemple : les cellules
C3....D8....E7....etc.
Avec un bouton, je puisse effectuer la macro dans les cellule
sélectionnées.
--
Cordialement
Guy

"JB"
Sub essai()
CreeShapes Range("B2"), "texte1", "texte2"
CreeShapes Range("E3"), "texte3", "texte4"
End Sub

Sub CreeShapes(c, texte1, texte2)
On Error Resume Next
ActiveSheet.Shapes(c.Address & "1").Delete
ActiveSheet.Shapes(c.Address & "2").Delete
With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Height)
.OLEFormat.Object.Characters.Text = texte1
.OLEFormat.Object.Characters.Font.Size = 7
.Fill.ForeColor.RGB = RGB(255, 0, 0)
.Line.ForeColor.RGB = RGB(255, 0, 0)
.IncrementRotation 180
.Name = c.Address & "1"
End With
With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Height)
.OLEFormat.Object.Characters.Text = texte2
.OLEFormat.Object.Characters.Font.Size = 7
.Fill.ForeColor.RGB = RGB(0, 255, 0)
.Line.ForeColor.RGB = RGB(0, 255, 0)
.Name = c.Address & "2"
End With
End Sub

Sub supshapes()
Sheets(1).DrawingObjects.Delete
End Sub

On 21 juin, 11:36, JB


> Sub essai()
> CreeShapes Range("B2"), "texte1", "texte2"
> CreeShapes Range("E3"), "texte3", "texte4"
> End Sub

> Sub CreeShapes(c, texte1, texte2)
> With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
> Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Height)
> .OLEFormat.Object.Characters.Text = texte1
> .OLEFormat.Object.Characters.Font.Size = 7
> .Fill.ForeColor.RGB = RGB(255, 0, 0)
> .Line.ForeColor.RGB = RGB(255, 0, 0)
> .IncrementRotation 180
> End With
> With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
> Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Height)
> .OLEFormat.Object.Characters.Text = texte2
> .OLEFormat.Object.Characters.Font.Size = 7
> .Fill.ForeColor.RGB = RGB(0, 255, 0)
> .Line.ForeColor.RGB = RGB(0, 255, 0)
> End With
> End Sub

> Sub supshapes()
> Sheets(1).DrawingObjects.Delete
> End Sub

>http://cjoint.com/?gvlK2hGqxe

> JB

> On 21 juin, 10:08, "Guy72"
> > Bonjour JB
> > Merci.
> > Par contre, j'ai l'intention de faire cette opération dans pas mal de
> > cellules.
> > comment je peux faire sans avoir à remplacer la cellule B2 à chaque
> > fois
> > ?
> > Ou de faire une copie aussi à chaque fois ?
> > --
> > Cordialement
> > Guy

> > "JB" > >
> > Avec texte:

> > Sub CreeShapes()
> > Set c = Range("B2")
> > With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
> > Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Height)
> > .OLEFormat.Object.Characters.Text = "Texte"
> > .OLEFormat.Object.Characters.Font.Size = 7
> > .Fill.ForeColor.RGB = RGB(255, 0, 0)
> > .Line.ForeColor.RGB = RGB(255, 0, 0)
> > .IncrementRotation 180
> > End With
> > With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
> > Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Height)
> > .OLEFormat.Object.Characters.Text = "Texte"
> > .OLEFormat.Object.Characters.Font.Size = 7
> > .Fill.ForeColor.RGB = RGB(0, 255, 0)
> > .Line.ForeColor.RGB = RGB(0, 255, 0)
> > End With
> > End Sub

> > Sub supshapes()
> > Sheets(1).DrawingObjects.Delete
> > End Sub

> > JB

> > On 21 juin, 08:46, JB
> > > Bonjour,

> > > Sub CreeShapes()
> > > Set c = Range("B2")
> > > With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
> > > Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Height)
> > > .Fill.ForeColor.RGB = RGB(255, 0, 0)
> > > .Line.ForeColor.RGB = RGB(255, 0, 0)
> > > .IncrementRotation 180
> > > End With
> > > With ActiveSheet.Shapes.AddShape(Type:=msoShapeRightTriangle, _
> > > Left:=c.Left, Top:=c.Top + 1, Width:=c.Width, Height:=c.Height)
> > > .Fill.ForeColor.RGB = RGB(0, 255, 0)
> > > .Line.ForeColor.RGB = RGB(0, 255, 0)
> > > End With
> > > End Sub

> > > Sub supshapes()
> > > Sheets(1).DrawingObjects.Delete
> > > End Sub

> > >http://cjoint.com/?gviUKoFRfU

> > > JBhttp://boisgontierjacques.free.fr/

> > > On 21 juin, 00:40, "Guy72"
> > > > Bonsoir,
> > > > Si on peut séparer une cellule par une diagonale.
> > > > Alors peut on mettre une couleur différente dans les deux parties
> > > > de
> > > > la
> > > > cellule ?
> > > > --
> > > > Cordialement
> > > > Guy- Masquer le texte des messages précédents -

> > > - Afficher le texte des messages précédents -- Masquer le texte des
> > > messages précédents -

> > - Afficher le texte des messages précédents -- Masquer le texte des
> > messages précédents -

> - Afficher le texte des messages précédents -- Masquer le texte des
> messages précédents -

- Afficher le texte des messages précédents -


Publicité
Poster une réponse
Anonyme