1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
| Function LineChart(Points As Range)
Const KMg = 2, KTag = "Line"
Dim Ptsc$, Ptsp$, nom$, Ref As Range, ShRg(), Bcle&, Cnt&: Dim Min#, Max#, Pts, Lg#, Ht#
On Error Resume Next
With Points
If .Rows.Count > 1 And .Columns.Count > 1 Then
LineChart = CVErr(xlErrValue): Exit Function
End If
Pts = .Value: Cnt = .Count
ReDim ShRg(1 To Cnt - 1)
If .Columns.Count > 1 Then Pts = WorksheetFunction.Transpose(Pts)
End With
Set Ref = Application.Caller
With Ref
.Worksheet.Shapes(KTag & .Address).Delete
Min = WorksheetFunction.Min(Pts)
Max = WorksheetFunction.Max(Pts)
Lg = (.Width - (KMg * 2)) / (Cnt - 1)
Ht = (.Height - (KMg * 2)) / (Max - Min)
Ptsp = Cells(2, 10).Value
For Bcle = 1 To Cnt - 1
With .Worksheet.Shapes.AddLine( _
KMg + .Left + Lg * (Bcle - 1), _
KMg + .Top + (Max - Pts(Bcle, 1)) * Ht, _
KMg + .Left + Lg * Bcle, _
KMg + .Top + (Max - Pts(Bcle + 1, 1)) * Ht)
ShRg(Bcle) = .Name
nom = ShRg(Bcle)
Ptsc = Pts(Bcle + 1, 1)
ActiveSheet.Shapes(nom).Select
Selection.ShapeRange.Line.Weight = 2#
If Ptsc < Ptsp Then
Selection.ShapeRange.Line.ForeColor.SchemeColor = 2
Else
Selection.ShapeRange.Line.ForeColor.SchemeColor = 3
End If
If Bcle Mod 2 <> 0 Then
Selection.ShapeRange.Line.DashStyle = msoLineRoundDot
End If
Ptsp = Ptsc
ShRg(Bcle) = .Name
End With
Next Bcle
With .Worksheet.Shapes.Range(ShRg)
.Group
.Name = KTag & Ref.Address
End With
End With
LineChart = ""
End Function |
Petit graphique simple dans une cellule
Répondre avec citation
Envoyé par Philippe JOCHMANS
Partager