Tracé d'une flèche selon un angle

Créer une discussion
Répondre
  • Initiateur de la discussion Initiateur de la discussion pascal82
  • 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
P

pascal82

XLDnaute Occasionnel
Bonjour à tous,

J'aimerai visualiser par tracé d' une flèche la direction du vent en automatique mais je ne sais pas comment procéder ni par ou commencer.
PS: Je n'ai pas besoin d'une très grande précision, juste un aspect visuel

Merci pour votre aide
 

Pièces jointes

Trier par date Trier par votes
On peut se passer du cercle et utiliser une cellule (B8) de préférence carrée :
VB: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [B1:B2]) Is Nothing Then Exit Sub
Dim Cx#, Cy#, ventMax#, vent#, d#, A#, Ar#, Q As Byte
Dim FlipH As Boolean, FlipV1 As Boolean, FlipV2 As Boolean
Dim x1#, y1#, x2#, y2#

With [B8] 'cellule carrée
    Cx = .Left + .Width / 2 'centre
    Cy = .Top + .Height / 2
    ventMax = .Height 'cette taille correspond à la vitesse maximum de 40 m/s
End With

vent = ventMax * [B2] / 40 'amplitude du vent en points
d = -vent / 2 'centre de la flèche au centre du carré en points
A = [B1] Mod 360 'angle en degrés
Ar = A * Application.Pi / 180 'angle en radians
Q = 1 + Int(A / 90) 'quart utilisé

With ActiveSheet.Shapes("Vent") 'j'ai renommé la shape
    FlipH = Q < 3 And [Quart] > 2 Or Q > 2 And [Quart] < 3
    FlipV1 = (Q = 1 Or Q = 4) And ([Quart] = 2 Or [Quart] = 3)
    FlipV2 = (Q = 2 Or Q = 3) And ([Quart] = 1 Or [Quart] = 4)
    If FlipH Then .Flip msoFlipHorizontal
    If FlipV1 Or FlipV2 Then .Flip msoFlipVertical
    ThisWorkbook.Names.Add "Quart", Q 'mémorisation
    x1 = Cx + d * Sin(Ar)
    y1 = Cy - d * Cos(Ar)
    x2 = Cx + (d + vent) * Sin(Ar)
    y2 = Cy - (d + vent) * Cos(Ar)
    .Width = Abs(x1 - x2)
    .Height = Abs(y1 - y2)
    .Left = Application.Min(x1, x2)
    .Top = Application.Min(y1, y2)
End With

End Sub
 

Pièces jointes

Vote positif 0 Vote négatif
Bonjour lanier2, le forum,

Bon voyez le fichier joint avec 6 flèches dans 6 cellules.

Pour adapter la macro il suffit de faire une boucle de 1 à 6 :
VB: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [B1:G2]) Is Nothing Then Exit Sub
Dim n%, Cx#, Cy#, ventMax#, vent#, d#, A&, Ar#, Q As Byte
Dim Quart As Byte, FlipH As Boolean, FlipV1 As Boolean, FlipV2 As Boolean
Dim x1#, y1#, x2#, y2#

For n = 1 To 6 'pour 6 cellules et 6 flèches

    With [A5].Offset(, n) 'cellule carrée
        Cx = .Left + .Width / 2 'centre
        Cy = .Top + .Height / 2
        ventMax = .Height 'cette taille correspond à la vitesse maximum de 40 m/s
    End With

    vent = ventMax * [A2].Offset(, n) / 40 'amplitude du vent en points
    d = -vent / 2 'centre de la flèche au centre du carré en points
    With [A1].Offset(, n)
        If .Value < 0 Then .Value = Abs(.Value) 'nombre positif
        A = .Value Mod 360 'angle en degrés entier
    End With
    Ar = A * Application.Pi / 180 'angle en radians
    Q = 1 + Int(A / 90) 'quart utilisé

    With ActiveSheet.Shapes("Vent" & n) 'j'ai renommé la shape
        Quart = Evaluate("Quart" & n) 'nom défini
        FlipH = Q < 3 And Quart > 2 Or Q > 2 And Quart < 3
        FlipV1 = (Q = 1 Or Q = 4) And (Quart = 2 Or Quart = 3)
        FlipV2 = (Q = 2 Or Q = 3) And (Quart = 1 Or Quart = 4)
        If FlipH Then .Flip msoFlipHorizontal
        If FlipV1 Or FlipV2 Then .Flip msoFlipVertical
        ThisWorkbook.Names.Add "Quart" & n, Q 'mémorisation
        x1 = Cx + d * Sin(Ar)
        y1 = Cy - d * Cos(Ar)
        x2 = Cx + (d + vent) * Sin(Ar)
        y2 = Cy - (d + vent) * Cos(Ar)
        .Width = Abs(x1 - x2)
        .Height = Abs(y1 - y2)
        .Left = Application.Min(x1, x2)
        .Top = Application.Min(y1, y2)
    End With
    
Next

End Sub
A+
 

Pièces jointes

Vote positif 0 Vote négatif
job75 à dit:
On peut se passer du cercle et utiliser une cellule (B8) de préférence carrée :
VB: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [B1:B2]) Is Nothing Then Exit Sub
Dim Cx#, Cy#, ventMax#, vent#, d#, A#, Ar#, Q As Byte
Dim FlipH As Boolean, FlipV1 As Boolean, FlipV2 As Boolean
Dim x1#, y1#, x2#, y2#

With [B8] 'cellule carrée
    Cx = .Left + .Width / 2 'centre
    Cy = .Top + .Height / 2
    ventMax = .Height 'cette taille correspond à la vitesse maximum de 40 m/s
End With

vent = ventMax * [B2] / 40 'amplitude du vent en points
d = -vent / 2 'centre de la flèche au centre du carré en points
A = [B1] Mod 360 'angle en degrés
Ar = A * Application.Pi / 180 'angle en radians
Q = 1 + Int(A / 90) 'quart utilisé

With ActiveSheet.Shapes("Vent") 'j'ai renommé la shape
    FlipH = Q < 3 And [Quart] > 2 Or Q > 2 And [Quart] < 3
    FlipV1 = (Q = 1 Or Q = 4) And ([Quart] = 2 Or [Quart] = 3)
    FlipV2 = (Q = 2 Or Q = 3) And ([Quart] = 1 Or [Quart] = 4)
    If FlipH Then .Flip msoFlipHorizontal
    If FlipV1 Or FlipV2 Then .Flip msoFlipVertical
    ThisWorkbook.Names.Add "Quart", Q 'mémorisation
    x1 = Cx + d * Sin(Ar)
    y1 = Cy - d * Cos(Ar)
    x2 = Cx + (d + vent) * Sin(Ar)
    y2 = Cy - (d + vent) * Cos(Ar)
    .Width = Abs(x1 - x2)
    .Height = Abs(y1 - y2)
    .Left = Application.Min(x1, x2)
    .Top = Application.Min(y1, y2)
End With

End Sub
Cliquez pour agrandir...
Merci beaucoup
Top
David
 
Vote positif 0 Vote négatif
job75 à dit:
Bonjour lanier2, le forum,

Bon voyez le fichier joint avec 6 flèches dans 6 cellules.

Pour adapter la macro il suffit de faire une boucle de 1 à 6 :
VB: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [B1:G2]) Is Nothing Then Exit Sub
Dim n%, Cx#, Cy#, ventMax#, vent#, d#, A&, Ar#, Q As Byte
Dim Quart As Byte, FlipH As Boolean, FlipV1 As Boolean, FlipV2 As Boolean
Dim x1#, y1#, x2#, y2#

For n = 1 To 6 'pour 6 cellules et 6 flèches

    With [A5].Offset(, n) 'cellule carrée
        Cx = .Left + .Width / 2 'centre
        Cy = .Top + .Height / 2
        ventMax = .Height 'cette taille correspond à la vitesse maximum de 40 m/s
    End With

    vent = ventMax * [A2].Offset(, n) / 40 'amplitude du vent en points
    d = -vent / 2 'centre de la flèche au centre du carré en points
    With [A1].Offset(, n)
        If .Value < 0 Then .Value = Abs(.Value) 'nombre positif
        A = .Value Mod 360 'angle en degrés entier
    End With
    Ar = A * Application.Pi / 180 'angle en radians
    Q = 1 + Int(A / 90) 'quart utilisé

    With ActiveSheet.Shapes("Vent" & n) 'j'ai renommé la shape
        Quart = Evaluate("Quart" & n) 'nom défini
        FlipH = Q < 3 And Quart > 2 Or Q > 2 And Quart < 3
        FlipV1 = (Q = 1 Or Q = 4) And (Quart = 2 Or Quart = 3)
        FlipV2 = (Q = 2 Or Q = 3) And (Quart = 1 Or Quart = 4)
        If FlipH Then .Flip msoFlipHorizontal
        If FlipV1 Or FlipV2 Then .Flip msoFlipVertical
        ThisWorkbook.Names.Add "Quart" & n, Q 'mémorisation
        x1 = Cx + d * Sin(Ar)
        y1 = Cy - d * Cos(Ar)
        x2 = Cx + (d + vent) * Sin(Ar)
        y2 = Cy - (d + vent) * Cos(Ar)
        .Width = Abs(x1 - x2)
        .Height = Abs(y1 - y2)
        .Left = Application.Min(x1, x2)
        .Top = Application.Min(y1, y2)
    End With
   
Next

End Sub
A+
Cliquez pour agrandir...
Génial ca
Exactement mon besoin
Bonne journée
David
 
Vote positif 0 Vote négatif
lanier2 à dit:
Génial ca
Exactement mon besoin
Bonne journée
David
Cliquez pour agrandir...
Juste une modif
J'ai essayé en mettant les données en colonne
Et j'ai un message d'erreur

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [E15:F20]) Is Nothing Then Exit Sub
Dim n%, Cx#, Cy#, ventMax#, vent#, d#, A&, Ar#, Q As Byte
Dim Quart As Byte, FlipH As Boolean, FlipV1 As Boolean, FlipV2 As Boolean
Dim x1#, y1#, x2#, y2#

For n = 1 To 6 'pour 6 cellules et 6 flèches

With [A5].Offset(, n) 'cellule carrée
Cx = .Left + .Width / 2 'centre
Cy = .Top + .Height / 2
ventMax = .Height 'cette taille correspond à la vitesse maximum de 40 m/s
End With

vent = ventMax * [F14].Offset(, n) / 40 'amplitude du vent en points
d = -vent / 2 'centre de la flèche au centre du carré en points
With [E14].Offset(, n)
If .Value < 0 Then .Value = Abs(.Value) 'nombre positif
A = .Value Mod 360 'angle en degrés entier
End With
Ar = A * Application.Pi / 180 'angle en radians
Q = 1 + Int(A / 90) 'quart utilisé

With ActiveSheet.Shapes("Vent" & n) 'j'ai renommé la shape
Quart = Evaluate("Quart" & n) 'nom défini
FlipH = Q < 3 And Quart > 2 Or Q > 2 And Quart < 3
FlipV1 = (Q = 1 Or Q = 4) And (Quart = 2 Or Quart = 3)
FlipV2 = (Q = 2 Or Q = 3) And (Quart = 1 Or Quart = 4)
If FlipH Then .Flip msoFlipHorizontal
If FlipV1 Or FlipV2 Then .Flip msoFlipVertical
ThisWorkbook.Names.Add "Quart" & n, Q 'mémorisation
x1 = Cx + d * Sin(Ar)
y1 = Cy - d * Cos(Ar)
x2 = Cx + (d + vent) * Sin(Ar)
y2 = Cy - (d + vent) * Cos(Ar)
.Width = Abs(x1 - x2)
.Height = Abs(y1 - y2)
.Left = Application.Min(x1, x2)
.Top = Application.Min(y1, y2)
End With

Next

End Sub
 
Vote positif 0 Vote négatif
Bonjour tout le monde,
"Just for the fun" en utilisant ShapeRange.Rotation,
1727610961090.png
 

Pièces jointes

Dernière édition:
Vote positif 0 Vote négatif
Hello,
Si on doit tracer des flèches dans des cellules qui sont petites et rectangulaires voici une procédure qui fait ce tracé :
DrawArrow(Cellule, Nom, Taille, rotangle)
Cellule est la cellule où l'on doit tracer la flèche qui sera placée au milieu de la cellule. La longueur de la flèche sera fixe et égale à la hauteur de la ligne moins 4 pixels.
Nom est le nom qui sera donné à la forme.
Taille permet de choisir la taille de la flèche 0 petite , 1 moyenne, 2 grande à choisir en fonction de la taille des cellules.
rotangle permet de choisir l'angle de rotation de la flèche . 0 = 0° = vent du nord poisson mort
VB: 
Sub DrawArrow(Cellule, Nom, Taille, rotangle)
    Dim arrowType As MsoConnectorType
    arrowType = msoConnectorStraight
    ActiveSheet.Shapes.AddConnector(arrowType, _
        Cellule.Left + (Cellule.Width / 2), Cellule.Top + 2, _
        Cellule.Left + (Cellule.Width / 2), Cellule.Top + Cellule.Height - 2).Select
    Select Case Taille
        Case 0 ' small
           Selection.ShapeRange.Line.EndArrowheadLength = msoArrowheadShort
           Selection.ShapeRange.Line.EndArrowheadWidth = msoArrowheadNarrow
           Selection.ShapeRange.Line.Weight = 0.75
        Case 1 ' medium
           Selection.ShapeRange.Line.EndArrowheadLength = msoArrowheadLengthMedium
           Selection.ShapeRange.Line.EndArrowheadWidth = msoArrowheadWidthMedium
           Selection.ShapeRange.Line.Weight = 1
        Case 2 ' wide
           Selection.ShapeRange.Line.EndArrowheadLength = msoArrowheadLong
           Selection.ShapeRange.Line.EndArrowheadWidth = msoArrowheadWide
           Selection.ShapeRange.Line.Weight = 1.5
    End Select
    Selection.ShapeRange.Line.EndArrowheadStyle = msoArrowheadTriangle
    Selection.ShapeRange.Line.ForeColor.RGB = RGB(0, 128, 255)
    Selection.Name = Nom
    CenterRotation ActiveSheet.Shapes(Nom), rotangle
End Sub
Sub CenterRotation(shape As shape, ByVal rotangle As Double)
    Dim rad As Double, x As Double, y As Double
    Dim x1 As Double, x2 As Double
    x = shape.Top: y = shape.Left
    x1 = (shape.Width / 2) * -1
    x2 = shape.Height
    rad = rotangle * Atn(1) / 45
    With shape
        .Top = x + (.Height - .Width / 2 - x1 - x2) * (1 - Cos(rad)) / 2
        .Left = y + (.Height - .Width / 2 - x1 - x2) * Sin(rad) / 2
        .Rotation = rotangle
    End With
End Sub
Sub TracerFlèches()
Dim Cell, i As Integer, a As Double
i = 0: a = 0
For Each Cell In ActiveSheet.Range("A1:H1")
    DrawArrow Cell, "Flèche" & CStr(i), 0, a
    i = i + 1: a = a + 45
Next
a = 0
For Each Cell In ActiveSheet.Range("A2:H2")
    DrawArrow Cell, "Flèche" & CStr(i), 1, a
    i = i + 1: a = a + 45
Next
a = 0
For Each Cell In ActiveSheet.Range("A3:H3")
    DrawArrow Cell, "Flèche" & CStr(i), 2, a
    i = i + 1: a = a + 45
Next
End Sub
Flèches.png

Ami calmant, J.P
 
Dernière édition:
Vote positif 0 Vote négatif
Un petit souci
Si je mets n=5 ca fonctionne pour 5 fleche, n=6 ca fonctionne pour 6, mais n=7 ca fonctionne pas meme en creant 1 fleche nommée Vent7

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [E15:F21]) Is Nothing Then Exit Sub
Dim n%, Cx#, Cy#, ventMax#, vent#, d#, A&, Ar#, Q As Byte
Dim Quart As Byte, FlipH As Boolean, FlipV1 As Boolean, FlipV2 As Boolean
Dim x1#, y1#, x2#, y2#

For n = 1 To 7 'pour 6 cellules et 6 flèches

With [D14].Offset(n) 'cellule carrée
Cx = .Left + .Width / 2 'centre
Cy = .Top + .Height / 2
ventMax = .Height 'cette taille correspond à la vitesse maximum de 40 m/s
End With

vent = ventMax * [F14].Offset(n) / 13 'amplitude du vent en points
d = -vent / 2 'centre de la flèche au centre du carré en points
With [E14].Offset(n)
If .Value < 0 Then .Value = Abs(.Value) 'nombre positif
A = .Value Mod 360 'angle en degrés entier
End With
Ar = A * Application.Pi / 180 'angle en radians
Q = 1 + Int(A / 90) 'quart utilisé

With ActiveSheet.Shapes("Vent" & n) 'j'ai renommé la shape
Quart = Evaluate("Quart" & n) 'nom défini
FlipH = Q < 3 And Quart > 2 Or Q > 2 And Quart < 3
FlipV1 = (Q = 1 Or Q = 4) And (Quart = 2 Or Quart = 3)
FlipV2 = (Q = 2 Or Q = 3) And (Quart = 1 Or Quart = 4)
If FlipH Then .Flip msoFlipHorizontal
If FlipV1 Or FlipV2 Then .Flip msoFlipVertical
ThisWorkbook.Names.Add "Quart" & n, Q 'mémorisation
x1 = Cx + d * Sin(Ar)
y1 = Cy - d * Cos(Ar)
x2 = Cx + (d + vent) * Sin(Ar)
y2 = Cy - (d + vent) * Cos(Ar)
.Width = Abs(x1 - x2)
.Height = Abs(y1 - y2)
.Left = Application.Min(x1, x2)
.Top = Application.Min(y1, y2)
End With

Next

End Sub
 
Vote positif 0 Vote négatif
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

Y
  • Question Question
XL 2019 Masquer automatiquement des lignes selon la valeur d'une cellule ?
Réponses
2
Affichages
168
Yogean
Y
F
  • Question Question
XL 2019 Attribuer une notre selon un critère donné ?
Réponses
6
Affichages
851
Deadpool_CC
Deadpool_CC
Q
  • Question Question
Microsoft 365 Créer un formulaire pour duplication d'onglet avec tableau
Réponses
6
Affichages
587
job75
job75
B
  • Question Question
XL 2021 Transfert tableau structuré EXCEL à un endroit précis de WORD
Réponses
8
Affichages
1 K
job75
job75
M
  • Résolu(e)
Microsoft 365 enregistrement copie du classeur ouvert avec mot de passe et incrémentation
2
Réponses
27
Affichages
2 K
meyscal
M
L
  • Question Question
XL 2016 calendrier avec un diagramme de Gant
Réponses
3
Affichages
1 K
Sheldor
S
K
  • Question Question
Microsoft 365 Formule INDEX/EQUIV avec plusieurs valeurs pour une même en-tête
Réponses
2
Affichages
2 K
KLfy
K
chostra
  • Question Question
Microsoft 365 problème navigation et selection dans Combobox-Liste de choix
Réponses
4
Affichages
2 K
chostra
chostra
S
  • Question Question
XL 2016 Copier coller feuille dans un autre classeur excel
Réponses
8
Affichages
2 K
StanislasC
S
P
  • Question Question
Microsoft 365 Date et heure de début de production mini en fonction d'une date heure de fin impérative
2
Réponses
15
Affichages
2 K
xls_62
X
F
  • Question Question
XL 2019 Créer un tableau de bord pour gestion parc véhicules
2
Réponses
24
Affichages
7 K
Etoto
Etoto
S
  • Résolu(e)
XL 2016 Automatisé un planning bénévole pour un tournoi
5 6 7
Réponses
94
Affichages
10 K
simo161616
S
XLSM75
  • Question Question
XL 2019 Extraire données d'un classeur vers un autre en réorganisant et renommant les colonnes
Réponses
10
Affichages
2 K
XLSM75
XLSM75
A
  • Question Question
Microsoft 365 Insérer nom de l'onglet dans un chemin
Réponses
5
Affichages
3 K
vgendron
vgendron
L
  • Résolu(e)
XL 2016 Couper/coller avancé + SUPP ligne si possible
Réponses
9
Affichages
1 K
LumberJAAK
L
L
  • Question Question
Scinder valeur et ajouter le restant
Réponses
1
Affichages
921
Rouge
R
B
  • Question Question
Compter le nombre d'occurrences d'une valeur avec un critère OU un autre OU un autre
Réponses
5
Affichages
953
R@chid
R@chid
L
  • Résolu(e)
XL 2019 Liaison de données Word Excel et "méthode range de l'objet global a échoué"
Réponses
12
Affichages
3 K
Staple1600
Staple1600
A
  • Question Question
XL 2016 Affecter une couleur en fonction d'une tranche horaire / un état
Réponses
3
Affichages
2 K
Arthur_A
A
D
  • Question Question
XL pour MAC Retraitement (trop complexe pour moi) d'une base de données
3 4 5
Réponses
74
Affichages
10 K
didcac
D
Retour