Afficher un cercle si

vaffancolor a écrit :

Encore merci pour vos réponses.

Alors en gros le nom de mon image correspond au nom de la cellule R6.

If Target <> "" Then
        Sheets("DONNEES").Shapes(Target).Copy
        Target.Offset(0, 2).Select
        activesheet.Range ("R6")

        With image
    .Left = ActiveCell.Left - 867
    .Top = ActiveCell.Top + 8
        End With

     End If

Je crois qu'il y a un petit problème, non?

Merci

Bonjour,

Tu manipules un objet ("image") que tu n'as défini nulle part. Aussi, la ligne "activesheet.Range("R6")" n'est pas une instruction valide car tu ne fais rien avec cette cellule.

Essaies plutôt :

set image = shapes(Range("R6"))

Malheureusement ça ne marche pas...Bref merci pour votre patience, je vais laisser tomber les cercles dans les cellules.

Merci

Pedro22 a écrit :

vaffancolor a écrit :

Encore merci pour vos réponses.

Alors en gros le nom de mon image correspond au nom de la cellule R6.

If Target <> "" Then
        Sheets("DONNEES").Shapes(Target).Copy
        Target.Offset(0, 2).Select
        activesheet.Range ("R6")

        With image
    .Left = ActiveCell.Left - 867
    .Top = ActiveCell.Top + 8
        End With

     End If

Je crois qu'il y a un petit problème, non?

Merci

Bonjour,

Tu manipules un objet ("image") que tu n'as défini nulle part. Aussi, la ligne "activesheet.Range("R6")" n'est pas une instruction valide car tu ne fais rien avec cette cellule.

Essaies plutôt :

set image = shapes(Range("R6"))

Le truc c'est qu'il va chercher un image dans une autre feuille pour la coller dans la feuille active, ce serait plutôt

set image = activesheet.paste

non?

vaffancolor a écrit :

Malheureusement ça ne marche pas...Bref merci pour votre patience, je vais laisser tomber les cercles dans les cellules.

Merci

J'ai modifié le code essaye celui se trouvant dans EDIT, je n'y touche plus jusqu'à avoir un retour

@Ausecour,

Probablement ! Je débarque, alors je n'ai pas le sujet en main, mais tu t'en sors très bien

La difficulté c'est que le code d'origine n'a sans doute pas été écrit par vaffancolor et que VBA m'a encore l'air assez obscur pour lui. Partant de là, il est difficile de modifier un code que l'on ne comprends pas.

Il me dit...Incompatibilité de type

Erreur sur la ligne "Set image = activesheet.Paste

@Pedro22 c'est exactement ça

Si je comprends bien, tu veux récupérer une image dont tu connais le nom, pour la coller à une position bien précise sur une autre feuille (la feuille active au moment de lancer la macro) ?

Pedro22 a écrit :

Si je comprends bien, tu veux récupérer une image dont tu connais le nom, pour la coller à une position bien précise sur une autre feuille (la feuille active au moment de lancer la macro) ?

Oui c'est ca, par contre la feuille "DONNEES" ou se trouve les diff. images est en xlSheetVeryHidden.

Je précise que la macro ci dessous marche :

  If Target.Address = "$R$6" Then
      activesheet.Unprotect "??"
    '-- suppression
    For Each s In activesheet.Shapes
      If s.Type = 13 Then
        If s.TopLeftCell.Address = Target.Offset(0, -11).Address Then
          s.Delete
        End If
      End If
    Next s
    '--
    If Target <> "" Then
        Sheets("DONNEES").Shapes(Target).Copy
        Target.Offset(0, 2).Select
        activesheet.Paste
        Selection.ShapeRange.Left = ActiveCell.Left - 867
        Selection.ShapeRange.Top = ActiveCell.Top + 8
        Target.Select
     End If
     activesheet.Protect "??", True, True, True

  End If

En revanche elle n'est pas compatible avec la macro du cercle :

Private Sub Worksheet_Change(ByVal Target As Range) 'programme se déclanchant à chaque changement dans la feuille
    Dim forme As Shape
    Dim cel As Range

    'on commence d'abord par tester si notre plage contient la cellule F5
    If Intersect(Target, Range("F5")) Is Nothing Then
        Exit Sub 'si ce n'est pas le cas on sort de la procédure
    End If

    'on parcourt toutes les cellules qui se trouvent dans la plage
    For Each cel In Target.Cells
        If cel = "a" And Not Intersect(cel, Range("F5")) Is Nothing Then
        'on vérifie cette fois que la cellule est bien F5

            nom = ""
            On Error Resume Next 'on passe à la ligne suivante en cas d'erreur
            nom = ActiveSheet.Shapes.Range(Array("Forme" & cel.Address)).Name 'on regarde si la forme existe en tentant
            'de récupérer son nom, pour éviter de la recréer
            On Error GoTo 0

            If nom = "" Then
                'ajout d'une forme stockée dans forme
                Set forme = ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, cel.MergeArea.Left + 10, cel.MergeArea.Top + 47, _
                cel.MergeArea.Width - 20, cel.MergeArea.Height - 90)
                With forme
                .Name = "Forme" & cel.Address 'afin de donner un nom unique à chaque forme on y met l'adresse de la cellule traitée
                .Adjustments.Item(1) = 0.5
                .Fill.Visible = msoFalse
                .Line.ForeColor.RGB = RGB(0, 0, 0)
                .Line.Weight = 2
                End With
                Set forme = Nothing 'on vide l'objet forme
            End If
        ElseIf cel <> "a" And Not Intersect(cel, Range("F5")) Is Nothing Then 'si on vide la cellule ou qu'elle n'est pas égale à a
            On Error Resume Next
            ActiveSheet.Shapes.Range(Array("Forme" & cel.Address)).Delete
            On Error GoTo 0
        End If
    Next cel
End Sub

Si les deux sont insérées, seulement la 1er marche.

Merci

A tester en modifiant juste cette partie dans ton code :

If Target <> "" Then
        NomImage = Range ("R6").Value 'Récupère le nom de l'image en R6
        Sheets("DONNEES").Shapes(NomImage).Copy Target.Offset(0, 2) 'Copier l'image et la coller 2 cellules à droite de la cellule cible

        With Shapes(NomImage)
              .Left = Target.Offset(0, 2).Left - 867
              .Top = Target.Offset(0, 2).Top + 8
        End With
End If

Il est possible, voire probable que ça ne fonctionne pas ! C'est pas que j'ai pas confiance en moi, mais je n'ai pas d'expérience concernant les macros événement. On est tous là pour progresser donc je tente ma chance quand même !

C'est sûrement parce que j'ai mis cette ligne que tu n'arrives jamais à ton programme :

    'on commence d'abord par tester si notre plage contient la cellule F5
    If Intersect(Target, Range("F5")) Is Nothing Then
        Exit Sub 'si ce n'est pas le cas on sort de la procédure
    End If

Comme toi tu es sur r6, ça sort toute de suite

EDIT:

Je suppose que paste ne donne pas un objet mais un select alors

A essayer mais peut-être avec un activesheet.shapes.add() ça fonctionnerait?

J'ai essayé ca...

    Dim forme As Shape
    Dim cel As Range

    'on commence d'abord par tester si notre plage contient la cellule F5
  If Target.Address = "F5" Then
    'on parcourt toutes les cellules qui se trouvent dans la plage
    For Each cel In Target.Cells
        If cel = "a" And Not Intersect(cel, Range("F5")) Is Nothing Then
        'on vérifie cette fois que la cellule est bien F5

            nom = ""
            On Error Resume Next 'on passe à la ligne suivante en cas d'erreur
            nom = activesheet.Shapes.Range(Array("Forme" & cel.Address)).Name 'on regarde si la forme existe en tentant
            'de récupérer son nom, pour éviter de la recréer
            On Error GoTo 0

            If nom = "" Then
                'ajout d'une forme stockée dans forme
                Set forme = activesheet.Shapes.AddShape(msoShapeRoundedRectangle, cel.MergeArea.Left + 10, cel.MergeArea.Top + 47, _
                cel.MergeArea.Width - 20, cel.MergeArea.Height - 90)
                With forme
                .Name = "Forme" & cel.Address 'afin de donner un nom unique à chaque forme on y met l'adresse de la cellule traitée
                .Adjustments.Item(1) = 0.5
                .Fill.Visible = msoFalse
                .Line.ForeColor.RGB = RGB(0, 0, 0)
                .Line.Weight = 2
                End With
                Set forme = Nothing 'on vide l'objet forme
            End If
        ElseIf cel <> "a" And Not Intersect(cel, Range("F5")) Is Nothing Then 'si on vide la cellule ou qu'elle n'est pas égale à a
            On Error Resume Next
            activesheet.Shapes.Range(Array("Forme" & cel.Address)).Delete
            On Error GoTo 0
        End If
    Next cel
    End If

  If Target.Address = "$R$6" Then
      activesheet.Unprotect "??"
    '-- suppression
    For Each s In activesheet.Shapes
      If s.Type = 13 Then
        If s.TopLeftCell.Address = Target.Offset(0, -11).Address Then
          s.Delete
        End If
      End If
    Next s
    '--
    If Target <> "" Then
        Sheets("DONNEES").Shapes(Target).Copy
        Target.Offset(0, 2).Select
        activesheet.Paste
        Selection.ShapeRange.Left = ActiveCell.Left - 867
        Selection.ShapeRange.Top = ActiveCell.Top + 8
        Target.Select
     End If
     activesheet.Protect "??", True, True, True

  End If

La macro du cercle ne fait rien...Un code à copier coller serait plus simple et j'éviterai des erreurs

Bonjour,

Target.address renvoie $F$5, c'est donc normal qu'il ne fasse rien, comme $F$5 n'est jamais égal à F5

 Dim forme As Shape
    Dim cel As Range

 If Not Intersect(Target, activesheet.Range("F5")) Is Nothing Then
            nom = ""
            On Error Resume Next 'on passe à la ligne suivante en cas d'erreur
            nom = activesheet.Shapes.Range(Array("Forme" & cel.Address)).Name 'on regarde si la forme existe en tentant
            'de récupérer son nom, pour éviter de la recréer
            On Error GoTo 0

            If nom = "" Then
                'ajout d'une forme stockée dans forme
                Set forme = activesheet.Shapes.AddShape(msoShapeRoundedRectangle, cel.MergeArea.Left + 10, cel.MergeArea.Top + 47, _
                cel.MergeArea.Width - 20, cel.MergeArea.Height - 90)
                With forme
                .Name = "Forme" & cel.Address 'afin de donner un nom unique à chaque forme on y met l'adresse de la cellule traitée
                .Adjustments.Item(1) = 0.5
                .Fill.Visible = msoFalse
                .Line.ForeColor.RGB = RGB(0, 0, 0)
                .Line.Weight = 2
                End With
                Set forme = Nothing 'on vide l'objet forme
            End If
      ICI       ElseIf cel <> "a" And Not Intersect(cel, Range("F5")) Is Nothing Then 'si on vide la cellule ou qu'elle n'est pas égale à a
            On Error Resume Next
            activesheet.Shapes.Range(Array("Forme" & cel.Address)).Delete
            On Error GoTo 0
        End If

J'ai essayé ca mais encore un problème sur la ligne en jaune.

Quelle ligne est en jaune?

ElseIf cel <> "a" And Not Intersect(cel, Range("F5")) Is Nothing Then

(Erreur d'exécution 91 - Variable objet ou variable de bloc With non définie)

Bonjour,

cel est bien remplit quand tu la regardes avec un espion? Parce que normalement elle prend progressivement les cellules en objet... Elle se remplit via la commande Set

Ah mais oui, dans le code que tu me montres, il manque la boucle for each cel in target.cells et le set cel = nothing vers le set forme = nothing, c'est pou rça que ça ne marche pas, il manque la boucle!

Peut tu me rajouter la boucle directement dans la macro, merci pour ta patience

Bonjour,

Voici d'après moi la correction à tester, tu avais aussi enlevé un IF qui vérifiait que la valeur saisie dans la cellule était a, encore une erreur de recopie, je l'ai corigée également.

Dim forme As Shape
    Dim cel As Range

If Not Intersect(Target, activesheet.Range("F5")) Is Nothing Then
    For Each cel in Target.cells
        If cel.value = "a" then
            nom = ""
            On Error Resume Next 'on passe à la ligne suivante en cas d'erreur
            nom = activesheet.Shapes.Range(Array("Forme" & cel.Address)).Name 'on regarde si la forme existe en tentant
            'de récupérer son nom, pour éviter de la recréer
            On Error GoTo 0

            If nom = "" Then
                'ajout d'une forme stockée dans forme
                Set forme = activesheet.Shapes.AddShape(msoShapeRoundedRectangle, cel.MergeArea.Left + 10, cel.MergeArea.Top + 47, _
                cel.MergeArea.Width - 20, cel.MergeArea.Height - 90)
                With forme
                    .Name = "Forme" & cel.Address 'afin de donner un nom unique à chaque forme on y met l'adresse de la cellule traitée
                    .Adjustments.Item(1) = 0.5
                    .Fill.Visible = msoFalse
                    .Line.ForeColor.RGB = RGB(0, 0, 0)
                    .Line.Weight = 2
                End With
                Set forme = Nothing 'on vide l'objet forme
            End If
        ElseIf cel.value <> "a" And Not Intersect(cel, Range("F5")) Is Nothing Then 'si on vide la cellule ou qu'elle n'est pas égale à a
            On Error Resume Next
            activesheet.Shapes.Range(Array("Forme" & cel.Address)).Delete
            On Error GoTo 0
        End If
    Next cel
End If

J'y suis presque je le sens...

La valeur "a" de la cellule F5 s'affiche si =SI(R7="a";"a";"")

Le soucis c'est lorsque je modifie la cellule R7, et que la cellule F5 change en fonction, il ne passe rien :/

En gros je crois qu'il faut lui dire que lorsque c'est R7 qui change il doit appliquer la forme sur F5

Bonjour,

Sauf erreur de ma part, la macro se lance si tu te place sur F5, pas si sa valeur est modifiée via une formule.

Du coup, comme s'appelle la fonction "si la valeur est modifié par une formule?"