Modification d'une macro trouvée sur le web

[niiiiiiiiiico]

Bonjour à tous,

J'ai téléchargé un fichier excel à cette adresse :
Clearly and Simply: Choropleth Map Template France

C'est une carte de france dont les couleurs changent (par département) selon le critère choisi (taux de chômage, superficie, densité de population, etc.)

J'ai adapté ce modèle à mon besoin, mais j'aurais besoin d'une manip. En effet, les cinq critères que j'ai retenu sont sur une échelle bien distincte, alors que sur le fichier original il n'y a qu'une seule échelle.

J'ai donc crée 4 échelles supplémentaires, dont les plages ont été renommées comme suit : MapValueToColor2, MapValueToColor3, MapValueToColor4, MapValueToColor5

Comment modifier la macro pour qu'elle puisse tenir compte de ces échelles ?

Si D10 = 1, il faut que ce soit MapValueToColor
Si D10 = 2, il faut que ce soit MapValueToColor2
...
D10 = 5 => MapValueToColor5

Voici la macro :

Option Explicit

Function udf_RGB(myR As Byte, myG As Byte, myB As Byte) As Long

  udf_RGB = RGB(myR, myG, myB)

End Function

Sub CheckColor(myCell As Range, myNameToShape As String, myValueToColor As String)
Dim myShape As Shape
Dim myTargetCell As Range
Dim myColorCode As Long
  
On Error GoTo Catch
  Set myTargetCell = Range(myNameToShape).Columns(1).Find(myCell.Name.Name, LookAt:=xlWhole)
  Set myShape = Sheets(1).Shapes(myTargetCell.Offset(0, 1))
  GoTo Finally

Catch:
  Exit Sub
Finally:
  
  On Error GoTo 0
  
  If myCell.Value < Range(myValueToColor).Cells(2, 1).Value Then
    myColorCode = Range(myValueToColor).Cells(1, 2).Value
  Else
    myColorCode = Application.WorksheetFunction.VLookup(myCell.Value, Range(myValueToColor), 2, True)
  End If
  
  myShape.Fill.ForeColor.RGB = myColorCode
  
End Sub

Sub UpdateMap()
Dim myCell As Range
  
  Application.ScreenUpdating = False
 
  For Each myCell In Range("MapNameToShape").Columns(1).Cells
     CheckColor Range(myCell.Value), "MapNameToShape", "MapValueToColor"
  Next myCell
  
  Application.ScreenUpdating = True
  
End Sub

Merci à tous pour votre précieuse aide !

 

[pierrejean]

Re : Modification d'une macro trouvée sur le web

bonjour nico

A tester:

Sub UpdateMap()
Dim myCell As Range
[COLOR=blue]couleurs = Array("MapValueToColor", "MapValueToColor2", "MapValueToColor3", "MapValueToColor4", "MapValueToColor5")
[/COLOR]  Application.ScreenUpdating = False
[COLOR=blue]nb = Range("D10")
[/COLOR]  For Each myCell In Range("MapNameToShape").Columns(1).Cells
     CheckColor Range(myCell.Value), "MapNameToShape",[COLOR=blue] couleurs(nb - 1)
[/COLOR]  Next myCell
  
  Application.ScreenUpdating = True
  
End Sub

 

[niiiiiiiiiico]

Re : Modification d'une macro trouvée sur le web

Bonjour pierrejean et merci de la réponse,

J'ai ce message d'erreur :

Erreur de compilation : variable non définie

Et j'ai Sub UpdateMap() qui se surligne en jaune

 

[pierrejean]

Re : Modification d'une macro trouvée sur le web

Re
Ajouter

Dim nb as integer

 

[niiiiiiiiiico]

Re : Modification d'une macro trouvée sur le web

Re,

Même message d'erreur (j'ai rejouté le texte juste après Sub UpdateMap() )

 

[pierrejean]

Re : Modification d'une macro trouvée sur le web

Re
tester d'abord en supprimant Option explicit
Si cela fonctionne tester ensuite en ajoutant
Dim couleurs

 

[niiiiiiiiiico]

Re : Modification d'une macro trouvée sur le web

Re,

Non ça ne fonctionne tjs pas : type d'arguments byref incompatible

Mais j'ai qd même réussi sans modifier la macro

edit : Merci !