Afficher un cercle si
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
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?
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) ?
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?"