Créer carte Europe afficher bar d'histogramme et colorier chaque pays

bast0504 à dit:

(...) Grâce à toi j'ai trouvé la carte de l’Europe que je cherche. En revanche comment intégré de manière automatique chaque bar de mon histogramme sur les pays de la carte ? Chose pas simple j'en convient. (...)

Cliquez pour agrandir...

• sélectionner cette forme
• se placer dans la barre de formule (vérifier que la forme est bien toujours sélectionnée)
• repérer dans le tableau des données, la cellule où se trouve le nom de la forme (ex A19 pour la France)
• saisir dans la barre de formule, la formule = $B$19
• valider la formule
• la forme affiche la valeur en $B$19
• on pourrait éventuellement automatiser ces actions par macro

• cliquer une ou deux fois sur un pays pour le sélectionner (vérifier son nom dans la barre des noms à gauche de la barre des formules)
• amener une forme au premier plan pour rendre son texte visible (cliquer droit sur la forme pour afficher le menu)
• positionner le texte d'une forme en haut ou en bas pour le rendre visible (cliquer droit sur la forme pour afficher le menu)

bast0504 à dit:

(...) Comment pourrais-t-on faire figurer sur chaque pays une barre d'histogramme qui représenterait un niveau de vente. L'idée serait en mettant à jour un tableau de données des ventes les bars s'ajusteraient à la hausse comme à la baisse (...)

Cliquez pour agrandir...

Private Sub Worksheet_Change(ByVal Target As Range)
Dim xcell As Range
If Intersect(Target, Range("b2:b57")) Is Nothing Then Exit Sub

For Each xcell In Range("b2:b57")
If Existe(xcell.Offset(, -1)) Then
  If xcell >= 0 Then
    With ActiveSheet.Shapes(xcell.Offset(, -1).Value & "P")
      .Visible = True
      .Height = HP * xcell.Value / Range("s4")
      .Top = ActiveSheet.Shapes(xcell.Offset(, -1).Value & "N").Top - .Height
    End With
    ActiveSheet.Shapes(xcell.Offset(, -1).Value & "N").Visible = False
  Else
    With ActiveSheet.Shapes(xcell.Offset(, -1).Value & "N")
      .Visible = True
      .Height = -HN * xcell.Value / Range("s8")
    End With
    ActiveSheet.Shapes(xcell.Offset(, -1).Value & "P").Visible = False
  End If
End If
Next xcell
End Sub

Function Existe(x As Range) As Boolean
Dim shp As Shape
For Each shp In ActiveSheet.Shapes
  If shp.Name = x.Value & "P" Then
    Existe = True
    Exit Function
  End If
Next shp
End Function

Public Function HP()
  HP = Sheets("EUROPE").Shapes("CylP").Height
End Function
Function HN()
  HN = Sheets("EUROPE").Shapes("CylN").Height
End Function

mapomme à dit:

Re : Créer carte Europe afficher bar d'histogramme et colorier chaque pays

Bonjour bast0504



Comme je dois partir, un exemple fait en vitesse. Quelques pays seulement ont été pris en exemple. On peut changer leurs valeurs pour voir les modifications sur la carte. Ne pas effacer les barres en colonne Q, ni les formules en colonne S.

Le code:

VB:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim xcell As Range
If Intersect(Target, Range("b2:b57")) Is Nothing Then Exit Sub

For Each xcell In Range("b2:b57")
If Existe(xcell.Offset(, -1)) Then
  If xcell >= 0 Then
    With ActiveSheet.Shapes(xcell.Offset(, -1).Value & "P")
      .Visible = True
      .Height = HP * xcell.Value / Range("s4")
      .Top = ActiveSheet.Shapes(xcell.Offset(, -1).Value & "N").Top - .Height
    End With
    ActiveSheet.Shapes(xcell.Offset(, -1).Value & "N").Visible = False
  Else
    With ActiveSheet.Shapes(xcell.Offset(, -1).Value & "N")
      .Visible = True
      .Height = -HN * xcell.Value / Range("s8")
    End With
    ActiveSheet.Shapes(xcell.Offset(, -1).Value & "P").Visible = False
  End If
End If
Next xcell
End Sub

Function Existe(x As Range) As Boolean
Dim shp As Shape
For Each shp In ActiveSheet.Shapes
  If shp.Name = x.Value & "P" Then
    Existe = True
    Exit Function
  End If
Next shp
End Function

Public Function HP()
  HP = Sheets("EUROPE").Shapes("CylP").Height
End Function
Function HN()
  HN = Sheets("EUROPE").Shapes("CylN").Height
End Function

Cliquez pour agrandir...