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 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159
| Sub tracer_graphique()
Application.ScreenUpdating = False
Dim nbgraphiquesparjour As Range
Dim nbjourscomplets As Range
Dim nbgraphiquestotals As Range
Dim intervales As Range
Dim indgraphe1 As Range
Dim indgraphe2 As Range
Dim puissancemax As Range
Dim nomclient As Range
Dim nosga As Range
Dim nbdonneesinter As Range
Set feuilledonnees = Worksheets("Données graphiques")
Set parametres = Worksheets("Paramètres")
Set nbgraphiquesparjour = parametres.Range("B1")
Set nbjourscomplets = parametres.Range("B2")
Set nbgraphiquestotals = parametres.Range("B3")
Set intervales = parametres.Range("B4")
Set indgraphe1 = parametres.Range("B5")
Set indgraphe2 = parametres.Range("B6")
Set puissancemax = parametres.Range("B7")
Set nomclient = parametres.Range("F1")
Set nosga = parametres.Range("F2")
Set nbdonneesinter = parametres.Range("B9")
indexfeuilledonnes = feuilledonnees.Index
'Demande du nombre de graphiques par jour
entreenbgraphiqueparjour = InputBox("Combien de graphiques par jour voulez-vous", "Nombre de graphique journalier", 1)
If entreenbgraphiqueparjour = "" Then
Application.ScreenUpdating = True
Exit Sub
End If
nbgraphiquesparjour.Value = entreenbgraphiqueparjour
feuilledonnees.Select
'Déterminons le nombre de jours complets et le départ
i = 1
premier = 0
nbjours = 0
Do While Cells(i, 1) <> 0
If (Cells(i + 1, 1).Value - Cells(i, 1).Value) = 1 Then
nbjours = nbjours + 1
If premier < 1 Then
ligneXdepart = Cells(i + 1, 4).Row
premier = 2
End If
End If
i = i + 1
Loop
nbjourscomplets.Value = nbjours - 1
If nbgraphiquesparjour.Value <= 0 Then
tttt = MsgBox("Le nombre de graphiques journaliers est inférieur ou égal à 0.", vbExclamation + vbOKOnly, "Erreur de compilation")
Application.ScreenUpdating = True
Exit Sub
ElseIf intervales <= 0 Then
tttt = MsgBox("L'intervale de mesure est inférieur ou égal à 0.", vbExclamation + vbOKOnly, "Erreur de compilation")
Application.ScreenUpdating = True
Exit Sub
Else
nbdonnes = Round(24 * 60 / intervales.Value / nbgraphiquesparjour.Value, 0)
indexprecedant = indexfeuilledonnes + 1
End If
For j = 1 To nbgraphiquestotals
feuilledonnees.Select
colonneX = 2
colonneY = 3
If j > 1 Then
ligneXdepart = ligneXfin + 1
End If
ligneXfin = (ligneXdepart + nbdonnes - 1)
ligneYdepart = ligneXdepart
ligneYfin = ligneXfin
graphiquenom = "Profil de l'appel de puissance du " & Format(Cells(ligneXdepart, 1), "dddd, d mmmm yyyy") & Cells(ligneXdepart, colonneY + 2) & " - " & Format(Cells(ligneXdepart, colonneX), "hh:mm") & " à " & Format(Cells(ligneXfin, colonneX), "hh:mm")
seriededonnes = Format(Cells(ligneXdepart, colonneX - 1), "yyyy-mm-dd") & "-Graphe " & j
Range(Cells(ligneXdepart, colonneX), Cells(ligneYfin, colonneY)).Select
Charts.Add
With ActiveChart
.Name = seriededonnes
.ChartType = xlLine
.Location Where:=xlLocationAsNewSheet
.HasTitle = True
.ChartTitle.Text = graphiquenom
.Axes(xlCategory, xlPrimary).HasTitle = False
.Axes(xlValue, xlPrimary).HasTitle = False
.HasLegend = False
.PlotArea.Interior.ColorIndex = xlNone
.Move after:=Sheets(indexprecedant)
.Axes(xlCategory, xlPrimary).HasTitle = True
.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "Temps (heures)"
.Axes(xlValue, xlPrimary).HasTitle = True
.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Puissance (kW)"
End With
If j = 1 Then
indgraphe1.Value = ActiveChart.Index
ElseIf j = nbgraphiquestotals Then
indgraphe2.Value = ActiveChart.Index
End If
With ActiveChart.Axes(xlCategory)
.CrossesAt = 1
.TickLabelSpacing = nbdonneesinter
.TickMarkSpacing = nbdonneesinter
.AxisBetweenCategories = True
.ReversePlotOrder = False
.TickLabels.Orientation = xlUpward
End With
With ActiveChart.Axes(xlValue)
.MinimumScale = 0
.MaximumScaleIsAuto = True
.MinorUnitIsAuto = True
.MajorUnitIsAuto = True
.Crosses = xlAutomatic
.ReversePlotOrder = False
.ScaleType = xlLinear
.DisplayUnit = xlNone
.TickLabels.NumberFormat = "0.0"
End With
With ActiveChart.Axes(xlValue)
.MinimumScale = 0
.MaximumScale = puissancemax.Value
.MinorUnitIsAuto = True
.MajorUnitIsAuto = True
.Crosses = xlAutomatic
.ReversePlotOrder = False
.ScaleType = xlLinear
.DisplayUnit = xlNone
End With
ActiveChart.Deselect
indexprecedant = indexprecedant + 1
Next j
parametres.Select
Application.ScreenUpdating = True
Charts(1).Select
OKmise = MsgBox("Voulez-vous ajouter les entêtes et pieds de pages avec les informations suivantes?" & Chr(10) & Chr(10) & "Nom du client: " & nomclient & Chr(10) & "No SGA: " & nosga, vbYesNo + vbExclamation, "Mise en page")
If OKmise = vbYes Then
Application.Run ("miseenpage")
End If
Charts(1).Select
End Sub |
Partager