colorer shapes suivant cellules

Sub coloriage()
  For Each c In [communesJB]
    If c <> "" Then
      couleur = c.Interior.Color
      ActiveSheet.Shapes(c).Fill.ForeColor.RGB = couleur
    End If
  Next c
End Sub

Sub EcritNoDepart()
  For Each c In [communesJB]
    If c <> "" Then ecritShape c, c
  Next c
End Sub

Sub ecritShape(nomShape, Libellé, Optional posVert, Optional posHoriz)
    Application.Volatile
    With ActiveSheet.Shapes(nomShape).TextFrame2.TextRange
        .Characters.Text = Libellé
        .Characters.Font.Size = 6
        If IsMissing(posVert) Then
          .Parent.VerticalAnchor = msoAnchorMiddle
        Else
          If posVert = "Bas" Then
           .Parent.VerticalAnchor = msoAnchorBottom
          Else
           .Parent.VerticalAnchor = msoAnchorMiddle
          End If
        End If
        If IsMissing(posHoriz) Then
          .Parent.HorizontalAnchor = msoAnchorCenter
        Else
          If posHoriz = "Gauche" Then
           .Parent.HorizontalAnchor = msoAnchorNone
          Else
           .Parent.HorizontalAnchor = msoAnchorCenter
          End If
        End If
     End With
End Sub

Sub bulles()
  For Each s In ActiveSheet.Shapes
    If s.Type <> 8 Then
      ActiveSheet.Hyperlinks.Add Anchor:=s, Address:="", SubAddress:=""
      tmp = s.Name
      bulle = Application.VLookup(tmp, [communesjb], 1, False)
      If Not IsError(bulle) Then
         libdep = s.Name
         s.Hyperlink.ScreenTip = libdep
      Else
         s.Hyperlink.ScreenTip = "...."
      End If
    End If
  Next s
End Sub