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
| Option Explicit
'--------------------------------------------------------------------------------
' Colore la carte en fonction de la progression du CA
'--------------------------------------------------------------------------------
Sub ColorMap()
Dim oSheet As Excel.Worksheet ' Feuille
Dim lLine As Long ' Numéro de ligne
Dim loShape As Shape ' Forme
Dim lColor As Long ' Couleur
Dim nbCouleur As Integer ' Nombre de couleurs dans l'échelle de couleurs)
Dim couleurs() As Long ' Echelle de couleurs
Dim valMin As Long ' Valeur min
Dim valMax As Long ' Valeur max
Dim valDelta As Single ' max-min+1
Dim strLegende, val1, val2 As String ' Texte de la légende
Dim Cellules As Range ' Colonne à évaluer
Dim i As Integer
'Définit la taille de l'échelle de couleurs
nbCouleur = 15
ReDim couleurs(nbCouleur)
' Echelle de couleur
couleurs(1) = RGB(0, 51, 0) ' Vert pour les valeurs max
couleurs(2) = RGB(0, 128, 0)
couleurs(3) = RGB(0, 153, 0)
couleurs(4) = RGB(102, 255, 51)
couleurs(5) = RGB(153, 255, 51)
couleurs(6) = RGB(204, 255, 102)
couleurs(7) = RGB(255, 255, 102)
couleurs(8) = RGB(255, 204, 102)
couleurs(9) = RGB(255, 153, 51)
couleurs(10) = RGB(255, 102, 0)
couleurs(11) = RGB(255, 0, 0)
couleurs(12) = RGB(204, 0, 0)
couleurs(13) = RGB(165, 0, 33)
couleurs(14) = RGB(128, 0, 0)
couleurs(15) = RGB(51, 0, 0) ' Rouge pour les valeurs min
' Feuille contenant la carte
Set oSheet = ActiveSheet
' Plage de données
Set Cellules = oSheet.Range("C2:C531")
' Valeurs min et max et grille de valeurs de la plage de données
valMin = Application.WorksheetFunction.Min(Cellules)
valMax = Application.WorksheetFunction.Max(Cellules)
valDelta = (valMax - valMin) / nbCouleur
' Légende
' Désactive le remplissage de la légende
oSheet.Shapes("Légende").Fill.Visible = msoFalse
' Complète la légende
For Each loShape In oSheet.Shapes("Légende").GroupItems
' Couleurs de remplissage
For i = 1 To UBound(couleurs)
' Si la forme loShape contient le nom Legende
If loShape.Name = "Legende " & i Then
' Réactive le remplissage de la forme
loShape.Fill.Visible = True
' Type de remplissage = couleur unie
loShape.Fill.Solid
' Pas de transparence
loShape.Fill.Transparency = 0#
' Couleur de remplissage
loShape.Fill.ForeColor.RGB = couleurs(i)
' Texte de la légende
' val1 = valMin + (i - 1) * valDelta
' val2 = valMin + i * valDelta
val1 = valMax - i * valDelta
val2 = valMax - (i - 1) * valDelta
strLegende = FormatNumber(val1, 0) & " - " & FormatNumber(val2, 0)
loShape.TextFrame.Characters.Text = strLegende
' La forme a été trouvée => on sort de la boucle
Exit For
End If
Next i
Next
' Désactive le remplissage de la carte
oSheet.Shapes("CarteBasRhin").Fill.Visible = msoFalse
' Pour chaque ligne de la feuille
For lLine = oSheet.UsedRange.Row + 1 To oSheet.UsedRange.Row + oSheet.UsedRange.Rows.Count
' Couleurs de remplissage
For i = 1 To UBound(couleurs)
Select Case oSheet.Cells(lLine, 3)
' Case valMin + (i - 1) * valDelta To valMin + i * valDelta
Case valMax - i * valDelta To valMax - (i - 1) * valDelta
lColor = couleurs(i)
End Select
Next i
' Parcours les départements de la carte
For Each loShape In oSheet.Shapes("CarteBasRhin").GroupItems
' Si le nom de la forme loShape contient la valeur de la première colonne
If loShape.Name Like oSheet.Cells(lLine, 1) & "*" Then
' Réactive le remplissage de la forme
loShape.Fill.Visible = True
' Type de remplissage = couleur unie
loShape.Fill.Solid
' Pas de transparence
loShape.Fill.Transparency = 0#
' Couleur de remplissage
loShape.Fill.ForeColor.RGB = lColor
' La forme a été trouvée => on sort de la boucle
Exit For
End If
Next
Next
End Sub |
Partager