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 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115
| Sub Graphique()
'
Dim Reference As Variant
Dim Plage As Range
Dim Cel As Range
Dim OldCalculation As Long
'****************************
' A supprimer : temps d'exéc.
'Dim Debut, Fin
'****************************
'
With Application
OldCalculation = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
Reference = InputBox("Entrez la référence d'un produit")
'****************************
' A supprimer : temps d'exéc.
'Debut = Timer
'****************************
On Error Resume Next
Reference = CDbl(Reference)
If Err <> 0 Then
Err.Clear
GoTo SortieAnticipee
End If
With Application
.DisplayAlerts = False
ThisWorkbook.Sheets("Graphique").Delete
.DisplayAlerts = True
On Error GoTo 0
End With
Sheets.Add before:=ThisWorkbook.Sheets(1)
ActiveSheet.Name = "Graphique"
Set Cel = Range("B1")
For Each sh In Sheets
If Left(sh.Name, 3) = "PRO" Then
Cel.Offset(0, -1) = sh.Name
With Application
For Each Cel In Cells ' --> ON NE SORT JAMAIS DE LA BOUCLE
Cel = .Index(sh.Range("F:F"), .Match(Reference, sh.Range("B:B"), 0), 1)
Set Cel = Cel.Offset(1, 0)
Next Cel
End With
End If
Next sh
Set Plage = Range("A1", Range("B65536").End(xlUp))
Range("D5").Select
Charts.Add
With ActiveChart
.ChartType = xlLineMarkers
.SetSourceData Source:=Plage, PlotBy:=xlColumns
.Location Where:=xlLocationAsObject, Name:="Graphique"
End With
With ActiveChart
.HasTitle = True
.ChartTitle.Characters.Text = "Référence : " & Reference
.HasLegend = False
End With
ActiveSheet.ChartObjects("Graphique 1").Activate
With ActiveChart.Axes(xlCategory).TickLabels
.Alignment = xlCenter
.Orientation = xlUpward
End With
With ActiveSheet.ChartObjects("Graphique 1")
.Top = Range("D5").Top
.Left = Range("D5").Left
.Height = Range("K27").Top - Range("D5").Top
.Width = Range("K27").Left - Range("D5").Left
End With
Range("A1").Select
GoTo Fin
SortieAnticipee:
MsgBox prompt:="Sortie de la procédure" & vbCrLf & _
" sur votre demande" & vbCrLf & _
" ou erreur de saisie", _
Buttons:=vbInformation + vbOKOnly
Sheets("Execution").Select
Fin:
With Application
.Calculation = OldCalculation
.ScreenUpdating = True
End With
'****************************
' A supprimer : temps d'exéc.
'Fin = Timer
'MsgBox "Temps d'exécution (en s.) : " & (Fin - Debut)
'****************************
End Sub |
Partager