Macro qui se déclenche au changement d'une valeur de cellule

Bonjour à tous,

Je viens vers vous car j'ai un petit soucis. Dans le cadre de mon travail, j'ai un fichier de qualité qui est mis en place. Pour ce faire, j'ai crée un tableau de bord dont une partie de celui-ci est un remplissage d'étoiles. Ce remplissage se fait en fonction de la valeur d'une cellule. Ce que je souhaiterai faire c'est que le remplissage soit automatique. Et c'est là où je coince un peu. Pour expliquer le but de la manœuvre, c'est que la valeur de la cellule est une valeur calculée par un TCD. Sur le tableau de bord, j'ai des segments et donc j'aimerai que l'évènement se déclenche pour chaque segment.

Alors en "manuel", tout va bien le code ci-dessous fonctionne :

Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect([$L$34:S38], Target) Is Nothing And Target.Count = 1 Then
    '-- suppression
   Application.ScreenUpdating = False
   effaceToutesEtoiles
    For Each s In ActiveSheet.Shapes
      If s.Type = 13 Then
        If s.TopLeftCell.Address = Target.Address Then s.Delete
      End If
    Next s
    '--
    If Target <> "" Then
        Sheets("Images").Shapes("etoile").Copy
        Target.Select
        note = Target.Value: If note > 5 Then note = 5
        For i = 1 To note
          ActiveSheet.Paste
          Selection.ShapeRange.Left = ActiveCell.Left + 40 * i
          Selection.ShapeRange.Top = ActiveCell.Top + 5
        Next i
        If note - Int(note) >= 0.5 Then
          Sheets("Images").Shapes("etoile_demi").Copy
          ActiveSheet.Paste
          Selection.ShapeRange.Left = ActiveCell.Left + 40 * i
          Selection.ShapeRange.Top = ActiveCell.Top + 5
        End If

        Target.Select
     End If
  End If
End Sub

Mais quand je teste les segments, la valeur de la cellule change mais pas l'évènement correspondant.

J'ai testé celui-ci aussi, mais sans résultat :

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Address = "$L$34" Then
  Application.ScreenUpdating = False
   effaceToutesEtoiles
    For Each s In ActiveSheet.Shapes
      If s.Type = 13 Then
        If s.TopLeftCell.Address = Target.Address Then s.Delete
      End If
    Next s
    '--
    If Target <> "" Then
        Sheets("Images").Shapes("etoile").Copy
        Target.Select
        note = Target.Value: If note > 5 Then note = 5
        For i = 1 To note
          ActiveSheet.Paste
          Selection.ShapeRange.Left = ActiveCell.Left + 40 * i
          Selection.ShapeRange.Top = ActiveCell.Top + 5
        Next i
        If note - Int(note) >= 0.5 Then
          Sheets("Images").Shapes("etoile_demi").Copy
          ActiveSheet.Paste
          Selection.ShapeRange.Left = ActiveCell.Left + 40 * i
          Selection.ShapeRange.Top = ActiveCell.Top + 5
        End If

        Target.Select
     End If
End If
End Sub

Auriez vous une solution à me proposer ?

Merci d'avance

bonjour

oui : la solution consiste à supprimer tout le VBA et à travailler avec des formules (souvent des SOMMEPROD ou des TCD)

j'ai plusieurs entreprises dont je crée les KPI (indicateurs si tu préfères).

joins ton fichier ou un extrait significatif de ta question.

Bonjour,

merci pour la proposition. Voici un extrait en pièce jointe, j'espère qu'il est assez clair.

(Fichier joint en xlsx, macro dans le développeur)

Pas de retour suite à l'envoie du fichier.

Certains auraient ils une proposition ou une aide potentielle ?