Private Sub BoutonReinit_Click()
LancerReinitMonCamembert
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Not (Intersect(Target, Range("PLAGE_GRAPHIQUE")) Is Nothing) Then
LancerRepeindreEtOrdonnerMonCamembert
End If
End Sub
'=============================================
' Macros de la feuille Graphique
'=============================================
Sub LancerReinitMonCamembert()
Dim iSerie As Integer
ActiveSheet.ChartObjects("Graphique 3").Activate
'ici la dernière
iSerie = ActiveChart.SeriesCollection.Count
ReinitSerie ActiveChart.FullSeriesCollection(iSerie), ActiveSheet.Range("$L$3:$L$8"), ActiveSheet.Range("$K$3:$K$8")
End Sub
Sub LancerRepeindreEtOrdonnerMonCamembert()
Dim iSerie As Integer
ActiveSheet.ChartObjects("Graphique 3").Activate
'ici la dernière
iSerie = ActiveChart.SeriesCollection.Count
ReinitSerie ActiveChart.FullSeriesCollection(iSerie), ActiveSheet.Range("$L$3:$L$8"), ActiveSheet.Range("$K$3:$K$8")
RepeindreEtOrdonnerMonCamembert ActiveChart.FullSeriesCollection(iSerie), ActiveSheet.Range("$L$3:$L$8"), ActiveSheet.Range("$K$3:$K$8")
End Sub
Sub RepeindreEtOrdonnerMonCamembert(pSerie As Object, pPlageValues As Range, pPlageXValues As Range)
Dim i As Integer, j As Integer, k As Variant
Dim TabValeurs() As Variant, TabValeursTri() As Variant
Dim Valeurs As String, XValeurs As String
TabValeurs = pSerie.Values
' Tableau à 2 dim :
' dim 1 = n° d'item dans la série
' dim 2 = valeur de l'item dans la série
ReDim TabValeursTri(1 To 2, LBound(TabValeurs) To UBound(TabValeurs))
For i = LBound(TabValeurs) To UBound(TabValeurs)
TabValeursTri(1, i) = i
TabValeursTri(2, i) = TabValeurs(i)
Next i
' Tri du tableau par ordre décroissant des valeurs de la série
Tri2D TabValeursTri, False
Valeurs = ""
XValeurs = ""
For i = LBound(TabValeursTri, 2) To UBound(TabValeursTri, 2)
' on aurait pu écrire For i = 1 To pSerie.Points.Count
j = TabValeursTri(1, i)
If Valeurs = "" Then Valeurs = "=" Else Valeurs = Valeurs & ","
If XValeurs = "" Then XValeurs = "=" Else XValeurs = XValeurs & ","
' On redéfinit la plage de l'adresse de la plus grande valeur à la plus petite
k = pPlageValues(1, 1)
Valeurs = Valeurs & ActiveSheet.Name & "!" & pPlageValues(1, 1).Offset(j - 1, 0).Address
XValeurs = XValeurs & ActiveSheet.Name & "!" & pPlageXValues(1, 1).Offset(j - 1, 0).Address
' on colorise le secteur en fonction de son ordre (décroissant)
Select Case i
Case 1 ' Vert
pSerie.Points(j).Format.Fill.ForeColor.RGB = RGB(0, 255, 0)
Case 2 ' Bleu
pSerie.Points(j).Format.Fill.ForeColor.RGB = RGB(0, 0, 255)
Case 3 ' Jaune
pSerie.Points(j).Format.Fill.ForeColor.RGB = RGB(255, 255, 0)
Case 4 ' Cyan
pSerie.Points(j).Format.Fill.ForeColor.RGB = RGB(0, 255, 255)
Case 5 ' Magenta
pSerie.Points(j).Format.Fill.ForeColor.RGB = RGB(255, 0, 255)
Case 6 ' Rouge
pSerie.Points(j).Format.Fill.ForeColor.RGB = RGB(255, 0, 0)
Case Else
' ne doit pas arriver
MsgBox "Couleur non prévue pour la " & i & " ème valeur !"
End Select
Next i
' On actualise les plages de valeurs de la série (ordre décroissant)
pSerie.Values = Valeurs
pSerie.XValues = XValeurs
End Sub
Sub ReinitSerie(pSerie As Object, pPlageValues As Range, pPlageXValues As Range)
Dim i As Integer, j As Integer
Dim Valeurs As String, XValeurs As String
' On redéfinit les plages de valeurs de la série
Valeurs = "=" & ActiveSheet.Name & "!" & pPlageValues.Address
XValeurs = "=" & ActiveSheet.Name & "!" & pPlageXValues.Address
pSerie.Values = Valeurs
pSerie.XValues = XValeurs
' couleurs en dégradé de bleu
For i = 1 To pSerie.Points.Count
j = Application.Max(0, (255 - (i - 1) * 20))
pSerie.Points(i).Format.Fill.ForeColor.RGB = RGB(0, j, j)
Next i
End Sub
Sub Tri2D(pTableau2D(), pAsc As Boolean)
Dim i As Integer
Dim j As Integer
Dim Temp() As Variant
ReDim Temp(1 To 2)
'Tri par ordre Asc ou Desc de la 2ème dimension (la valeur des séries)
For i = LBound(pTableau2D, 2) To UBound(pTableau2D, 2)
For j = i + 1 To UBound(pTableau2D, 2)
If (CDbl(pTableau2D(2, i)) < CDbl(pTableau2D(2, j)) And Not (pAsc)) _
Or (CDbl(pTableau2D(2, i)) > CDbl(pTableau2D(2, j)) And (pAsc)) Then
Temp(1) = pTableau2D(1, j)
Temp(2) = pTableau2D(2, j)
pTableau2D(1, j) = pTableau2D(1, i)
pTableau2D(2, j) = pTableau2D(2, i)
pTableau2D(1, i) = Temp(1)
pTableau2D(2, i) = Temp(2)
End If
Next j
Next i
End Sub
'=============================================
' Macros de la feuille Couleurs
'=============================================
Sub AfficherInfosCouleur()
Dim Cellule As Range
Const R = 5, V = 6, B = 7
If ActiveSheet.Name <> "Couleurs" Then
MsgBox "pas sur la bonne feuille"
Exit Sub
End If
For Each Cellule In Range("COULEURS")
With Cellule
.Offset(0, 2) = .Interior.Color
.Offset(0, 3) = .Interior.ColorIndex
'extraire RVB
.Offset(0, R) = Int(.Interior.Color Mod 256)
.Offset(0, V) = Int((.Interior.Color Mod 65536) / 256)
.Offset(0, B) = Int(.Interior.Color / 65536)
' inverse RGB -> Color
.Offset(0, 9) = (.Offset(0, R) * 1) + (.Offset(0, V) * 256) + (.Offset(0, B) * 65536)
End With
Next
Set Cellule = Nothing
End Sub
Sub CouleurDepuisModele()
Dim Cellule As Range
Dim NomCelluleModele As String
On Error Resume Next
For Each Cellule In Range("A_COLORISER")
' Couleur par défaut
Cellule.Interior.Color = vbBlack
' Couleur du modèle
NomCelluleModele = "COULEUR_" & Cellule.Row
Cellule.Interior.Color = Range(NomCelluleModele).Interior.Color
Next Cellule
On Error GoTo 0
End Sub