XL 2019 Aide Carte de France interactive (créateur Jacques Boisgontier)

[JV33]

Bonjour à tous,

J'aurai besoin d'aide svp, en effet j'ai adapté la carte à mes besoin (trouvée sur votre forum, créateur Jacques Boisgontier), mais les couleurs des zone ne se mettent pas toutes à jour.

Qui a la solution svp?

Merci d'avance!

 

[Phil69970]

Bonjour @JV33

Quelques remarques :

1-

mais les couleurs des zone ne se mettent pas toutes à jour.

C'est à nous de trouver lesquelles ?

2- Le format XLS est vieux d'environ 10 à 15 ans
Maintenant les fichiers excel sont au format :

- XLSX sans macro
- XLSM avec des macros

Merci de ton retour

@Phil69970

 

[sylvanu]

Bonsoir, JV, Phil,
Une tentative en PJ avec ce que j'ai compris en modifiant la macro "coloriage" :

Sub coloriage()
  For Each c In [départ]
   If c <> "" Then
    ActiveSheet.Shapes("fr-" & c).Fill.ForeColor.RGB = vbWhite      ' Le dpt passe en blanc par défaut
    ca = c.Offset(, 1)
    If Application.CountIf([légende], ca) > 0 Then                  ' Si "ca" existe dans [légende]
        p = Application.Match(ca, [légende], 0)                     ' Index de "ca", attention dernier param 0 et non 1
        couleur = Range("légende").Cells(p, 1).Interior.Color       ' Extraire couleur
        ActiveSheet.Shapes("fr-" & c).Fill.ForeColor.RGB = couleur  ' appliquer couleur au shape
    End If
   End If
  Next c
End Sub

A noter que CR n'a pas d'affectation et que 32 dpt sont sans affectation.

 

[JV33]

Bonjour à tous,

Bonsoir, JV, Phil,
Une tentative en PJ avec ce que j'ai compris en modifiant la macro "coloriage" :

Sub coloriage()
  For Each c In [départ]
   If c <> "" Then
    ActiveSheet.Shapes("fr-" & c).Fill.ForeColor.RGB = vbWhite      ' Le dpt passe en blanc par défaut
    ca = c.Offset(, 1)
    If Application.CountIf([légende], ca) > 0 Then                  ' Si "ca" existe dans [légende]
        p = Application.Match(ca, [légende], 0)                     ' Index de "ca", attention dernier param 0 et non 1
        couleur = Range("légende").Cells(p, 1).Interior.Color       ' Extraire couleur
        ActiveSheet.Shapes("fr-" & c).Fill.ForeColor.RGB = couleur  ' appliquer couleur au shape
    End If
   End If
  Next c
End Sub

A noter que CR n'a pas d'affectation et que 32 dpt sont sans affectation.

Salut Sylvanu, merci pour ta solution. ça fonctionne!