Public APPEL As Boolean
Public R As Range
Type structPropertyXY
Value As Double
Size As Double
End Type
Type structXY
MinX As structPropertyXY
MinY As structPropertyXY
MaxX As structPropertyXY
MaxY As structPropertyXY
End Type
Sub MAJ_graphique()
Dim XY As structXY
Dim AJOUT As Double
Dim S As Worksheet
Dim var
Dim i&
Dim lig&
Dim col&
Dim SizeMax As Double
Set S = Sheets("Source graphe")
S.Activate
If Not APPEL Then
On Error Resume Next
Range("B15:D25").Interior.ColorIndex = xlNone
lig = ActiveCell.Row
col = ActiveCell.Column
Application.Goto Reference:=ActiveCell.Value
If Err = 1004 Then
Range("B15:D25").Activate
MsgBox ("Sélectionnez une cellule parmi ce tableau en fonction du produit et du mois")
Exit Sub
End If
On Error GoTo Erreur
Set R = Selection
End If
var = R
With XY
With .MaxX
.Value = var(1, 3)
.Size = var(1, 5)
End With
With .MinX
.Value = var(1, 3)
.Size = var(1, 5)
End With
With .MaxY
.Value = var(1, 4)
.Size = var(1, 5)
End With
With .MinY
.Value = var(1, 4)
.Size = var(1, 5)
End With
End With
SizeMax = -9999999
For i& = 1 To R.Rows.Count
If SizeMax < var(i&, 5) Then SizeMax = var(i&, 5)
With XY
With .MaxX
If var(i&, 3) > .Value Then
.Value = var(i&, 3)
.Size = var(i&, 5)
End If
End With
With .MinX
If var(i&, 3) < .Value Then
.Value = var(i&, 3)
.Size = var(i&, 5)
End If
End With
With .MaxY
If var(i&, 4) > .Value Then
.Value = var(i&, 4)
.Size = var(i&, 5)
End If
End With
With .MinY
If var(i&, 4) < .Value Then
.Value = var(i&, 4)
.Size = var(i&, 5)
End If
End With
End With
Next i&
R.Copy S.Cells(2, 1)
S.ChartObjects("Graphique").Activate
With ActiveChart
If .ChartGroups(1).SizeRepresents = xlSizeIsWidth Then
AJOUT = 1 'Diamètre
Else
AJOUT = 1.5 'Surface
End If
.HasTitle = True
.ChartTitle.Characters.Text = S.Cells(2, 1) & " " & R.Parent.Name
With .Axes(xlCategory)
.TickLabels.NumberFormat = "0.00"
.MinimumScale = Application.WorksheetFunction.RoundDown(XY.MinX.Value - AJOUT * _
((XY.MaxX.Value - XY.MinX.Value) * 1.7 / 10.5) / 2 * (XY.MinX.Size / SizeMax), 2)
.MaximumScale = Application.WorksheetFunction.RoundUp(XY.MaxX.Value + AJOUT * _
((XY.MaxX.Value - XY.MinX.Value) * 1.7 / 10.5) / 2 * (XY.MaxX.Size / SizeMax), 2)
.CrossesAt = S.Cells(5, 7)
.MinorUnitIsAuto = True
.MajorUnitIsAuto = True
End With
With .Axes(xlValue)
.TickLabels.NumberFormat = "0.00"
.MinimumScale = Application.WorksheetFunction.RoundDown(XY.MinY.Value - AJOUT * _
((XY.MaxY.Value - XY.MinY.Value) * 1.7 / 7) / 2 * (XY.MinY.Size / SizeMax), 2)
.MaximumScale = Application.WorksheetFunction.RoundUp(XY.MaxY.Value + AJOUT * _
((XY.MaxY.Value - XY.MinY.Value) * 1.7 / 7) / 2 * (XY.MaxY.Size / SizeMax), 2)
.CrossesAt = S.Cells(5, 8)
.MinorUnitIsAuto = True
.MajorUnitIsAuto = True
End With
End With
If Not APPEL Then
With S.Cells(lig, col)
.Select
.Interior.ColorIndex = 6
End With
Else
Range("B15:D25").Interior.ColorIndex = xlNone
End If
Erreur:
If Err <> 0 Then MsgBox "Erreur : " & Err.Number & vbCrLf & Err.Description
End Sub