If Not Intersect(Sh.TopLeftCell, Target.Offset(, 1)) Is
Nothing Then
Re-Bonjour,
En supplément, modifie les 2 premières lignes de code par ceci :
If Not Intersect(Target, Columns(1)) Is Nothing Then
If Target.Rows.Count > 1 Then Exit Sub 'Celle-ci est nouvelle
Attention, à la disposition de tes images en Colonne B de ta feuille BdD.
La procédure est basée sur la propriété TopLeftCell
d'un objet Range en l'occurrence dans le présent cas, des images. Si ton
image n'est pas méticuleusement placée en colonne B
et qu'elle empiète sur la colonne A de quelques millimètres ... la
procédure ne s'exécutera pas adéquatement ...Donc avant de
copier la procédure assure-toi de l'emplacement de tes images !!!
Salutations!
"michdenis" a écrit dans le message de
news:
Bonjour aife1,
Copie le code suivant dans le module code de ta feuille "Résultats" et tu
pries !
'-------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rg As Range, Sh As Shape, R As Variant, S As Object
If Not Intersect(Target, Columns(1)) Is Nothing Then
With Worksheets("BdD")
R = Application.Match(Target, .Range("A:A"), 0)
If Not IsError(R) Then
Set Rg = .Range("A" & R)
Else
On Error GoTo 0
For Each Sh In Shapes
If Not Intersect(Sh.TopLeftCell, Target.Offset(, 1)) Is
Nothing Then
Sh.Delete
Exit Sub
End If
Next
End If
For Each Sh In .Shapes
If Not Intersect(Sh.TopLeftCell, Rg.Offset(, 1)) Is
Nothing Then
On Error Resume Next
Shapes("Picture " & Split(Sh.Name, " ")(1)).Delete
On Error GoTo 0
Sh.Copy
ActiveSheet.Paste
Set S = Selection
Set Rg = Target.Offset(, 1)
With Rg
Largeur = .Offset(, 1)(, .Columns.Count).Left -
.Left
Hauteur = .Offset(.Rows.Count).Top - .Item(1).Top
End With
With S
.Name = Sh.Name
.Left = Rg.Left
.Top = Rg.Top
'Largeur de l'image
S.Width = Largeur
'Hauteur de l'image
S.Height = Hauteur
'Est-ce que l'image doit se déplacer avec les
cellules
'voici les 3 constantes possibles
.Placement = xlFreeFloating 'or xlmove or
xlMoveAndSize
'Verrouillé ou pas
.Locked = True 'or False
End With
Rg.Offset(, 1).Select
End If
Next
End With
End If
Set Rg = Nothing: Set Sh = Nothing: Set S = Nothing
End Sub
'-------------------------------------
Salutations!
"aife1" a écrit dans le message de
news:%
Bonjour à tous !!
Je sais que cette question a déjà été posée, mais les réponses ne
correspondent pas exactement à mes attentes.
Dans un classeur, j'ai deux feuilles : BdD et Résultats.
La feuille BdD comporte une base de données qui se présente de la façon
suivante :
colonne A : nom du film
colonne B : image du film
colonne C : genre du film
colonne D : acteurs du film
...
Si dans la feuille Résultats je tape, dans la colonne A, le nom d'un film
qui se trouve dans la base de données, je voudrais que l'image se place
automatiquement en colonne B; le genre en colonne C, ...
Pour le texte, j'y arrive, c'est juste pour l'image.
A savoir que certains films ne comportent pas d'image et que dans la
colonne
A de la feuille Résultats, il peut y avoir un ou plusieurs films.
Merci d'avance pour vos conseils ...
If Not Intersect(Sh.TopLeftCell, Target.Offset(, 1)) Is
Nothing Then
Re-Bonjour,
En supplément, modifie les 2 premières lignes de code par ceci :
If Not Intersect(Target, Columns(1)) Is Nothing Then
If Target.Rows.Count > 1 Then Exit Sub 'Celle-ci est nouvelle
Attention, à la disposition de tes images en Colonne B de ta feuille BdD.
La procédure est basée sur la propriété TopLeftCell
d'un objet Range en l'occurrence dans le présent cas, des images. Si ton
image n'est pas méticuleusement placée en colonne B
et qu'elle empiète sur la colonne A de quelques millimètres ... la
procédure ne s'exécutera pas adéquatement ...Donc avant de
copier la procédure assure-toi de l'emplacement de tes images !!!
Salutations!
"michdenis" <michdenis@hotmail.com> a écrit dans le message de
news:OxKjzbxfEHA.2764@TK2MSFTNGP11.phx.gbl...
Bonjour aife1,
Copie le code suivant dans le module code de ta feuille "Résultats" et tu
pries !
'-------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rg As Range, Sh As Shape, R As Variant, S As Object
If Not Intersect(Target, Columns(1)) Is Nothing Then
With Worksheets("BdD")
R = Application.Match(Target, .Range("A:A"), 0)
If Not IsError(R) Then
Set Rg = .Range("A" & R)
Else
On Error GoTo 0
For Each Sh In Shapes
If Not Intersect(Sh.TopLeftCell, Target.Offset(, 1)) Is
Nothing Then
Sh.Delete
Exit Sub
End If
Next
End If
For Each Sh In .Shapes
If Not Intersect(Sh.TopLeftCell, Rg.Offset(, 1)) Is
Nothing Then
On Error Resume Next
Shapes("Picture " & Split(Sh.Name, " ")(1)).Delete
On Error GoTo 0
Sh.Copy
ActiveSheet.Paste
Set S = Selection
Set Rg = Target.Offset(, 1)
With Rg
Largeur = .Offset(, 1)(, .Columns.Count).Left -
.Left
Hauteur = .Offset(.Rows.Count).Top - .Item(1).Top
End With
With S
.Name = Sh.Name
.Left = Rg.Left
.Top = Rg.Top
'Largeur de l'image
S.Width = Largeur
'Hauteur de l'image
S.Height = Hauteur
'Est-ce que l'image doit se déplacer avec les
cellules
'voici les 3 constantes possibles
.Placement = xlFreeFloating 'or xlmove or
xlMoveAndSize
'Verrouillé ou pas
.Locked = True 'or False
End With
Rg.Offset(, 1).Select
End If
Next
End With
End If
Set Rg = Nothing: Set Sh = Nothing: Set S = Nothing
End Sub
'-------------------------------------
Salutations!
"aife1" <aife1@wanadoo.fr> a écrit dans le message de
news:%23UizZUrfEHA.3536@TK2MSFTNGP12.phx.gbl...
Bonjour à tous !!
Je sais que cette question a déjà été posée, mais les réponses ne
correspondent pas exactement à mes attentes.
Dans un classeur, j'ai deux feuilles : BdD et Résultats.
La feuille BdD comporte une base de données qui se présente de la façon
suivante :
colonne A : nom du film
colonne B : image du film
colonne C : genre du film
colonne D : acteurs du film
...
Si dans la feuille Résultats je tape, dans la colonne A, le nom d'un film
qui se trouve dans la base de données, je voudrais que l'image se place
automatiquement en colonne B; le genre en colonne C, ...
Pour le texte, j'y arrive, c'est juste pour l'image.
A savoir que certains films ne comportent pas d'image et que dans la
colonne
A de la feuille Résultats, il peut y avoir un ou plusieurs films.
Merci d'avance pour vos conseils ...
If Not Intersect(Sh.TopLeftCell, Target.Offset(, 1)) Is
Nothing Then
Re-Bonjour,
En supplément, modifie les 2 premières lignes de code par ceci :
If Not Intersect(Target, Columns(1)) Is Nothing Then
If Target.Rows.Count > 1 Then Exit Sub 'Celle-ci est nouvelle
Attention, à la disposition de tes images en Colonne B de ta feuille BdD.
La procédure est basée sur la propriété TopLeftCell
d'un objet Range en l'occurrence dans le présent cas, des images. Si ton
image n'est pas méticuleusement placée en colonne B
et qu'elle empiète sur la colonne A de quelques millimètres ... la
procédure ne s'exécutera pas adéquatement ...Donc avant de
copier la procédure assure-toi de l'emplacement de tes images !!!
Salutations!
"michdenis" a écrit dans le message de
news:
Bonjour aife1,
Copie le code suivant dans le module code de ta feuille "Résultats" et tu
pries !
'-------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rg As Range, Sh As Shape, R As Variant, S As Object
If Not Intersect(Target, Columns(1)) Is Nothing Then
With Worksheets("BdD")
R = Application.Match(Target, .Range("A:A"), 0)
If Not IsError(R) Then
Set Rg = .Range("A" & R)
Else
On Error GoTo 0
For Each Sh In Shapes
If Not Intersect(Sh.TopLeftCell, Target.Offset(, 1)) Is
Nothing Then
Sh.Delete
Exit Sub
End If
Next
End If
For Each Sh In .Shapes
If Not Intersect(Sh.TopLeftCell, Rg.Offset(, 1)) Is
Nothing Then
On Error Resume Next
Shapes("Picture " & Split(Sh.Name, " ")(1)).Delete
On Error GoTo 0
Sh.Copy
ActiveSheet.Paste
Set S = Selection
Set Rg = Target.Offset(, 1)
With Rg
Largeur = .Offset(, 1)(, .Columns.Count).Left -
.Left
Hauteur = .Offset(.Rows.Count).Top - .Item(1).Top
End With
With S
.Name = Sh.Name
.Left = Rg.Left
.Top = Rg.Top
'Largeur de l'image
S.Width = Largeur
'Hauteur de l'image
S.Height = Hauteur
'Est-ce que l'image doit se déplacer avec les
cellules
'voici les 3 constantes possibles
.Placement = xlFreeFloating 'or xlmove or
xlMoveAndSize
'Verrouillé ou pas
.Locked = True 'or False
End With
Rg.Offset(, 1).Select
End If
Next
End With
End If
Set Rg = Nothing: Set Sh = Nothing: Set S = Nothing
End Sub
'-------------------------------------
Salutations!
"aife1" a écrit dans le message de
news:%
Bonjour à tous !!
Je sais que cette question a déjà été posée, mais les réponses ne
correspondent pas exactement à mes attentes.
Dans un classeur, j'ai deux feuilles : BdD et Résultats.
La feuille BdD comporte une base de données qui se présente de la façon
suivante :
colonne A : nom du film
colonne B : image du film
colonne C : genre du film
colonne D : acteurs du film
...
Si dans la feuille Résultats je tape, dans la colonne A, le nom d'un film
qui se trouve dans la base de données, je voudrais que l'image se place
automatiquement en colonne B; le genre en colonne C, ...
Pour le texte, j'y arrive, c'est juste pour l'image.
A savoir que certains films ne comportent pas d'image et que dans la
colonne
A de la feuille Résultats, il peut y avoir un ou plusieurs films.
Merci d'avance pour vos conseils ...
Bonjour Michdenis !
Tout d'abord, un très grand merci pour ton aide.
Ton code marche, mais il y une "erreur d'exécution 1004 : La méthode
'Intersect' de l'objet_Global a échoué" au niveau de la ligne suivante :If Not Intersect(Sh.TopLeftCell, Target.Offset(, 1)) Is
Nothing Then
A part cela, l'image se copie à merveille.
C'est ce que je comprend pas (je m'y connais pas trop en VBA), malgré
l'erreur, ça marche ! On ne pourrait pas mettre dans le code un truc qui
fermerait la boîte d'erreur ?
Merci encore ...
"michdenis" a écrit dans le message de
news:Re-Bonjour,
En supplément, modifie les 2 premières lignes de code par ceci :
If Not Intersect(Target, Columns(1)) Is Nothing Then
If Target.Rows.Count > 1 Then Exit Sub 'Celle-ci est nouvelle
Attention, à la disposition de tes images en Colonne B de ta feuille
BdD.
La procédure est basée sur la propriété TopLeftCelld'un objet Range en l'occurrence dans le présent cas, des images. Si ton
image n'est pas méticuleusement placée en colonne Bet qu'elle empiète sur la colonne A de quelques millimètres ... la
procédure ne s'exécutera pas adéquatement ...Donc avant decopier la procédure assure-toi de l'emplacement de tes images !!!
Salutations!
"michdenis" a écrit dans le message de
news:Bonjour aife1,
Copie le code suivant dans le module code de ta feuille "Résultats" et
tu
pries !
'-------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rg As Range, Sh As Shape, R As Variant, S As Object
If Not Intersect(Target, Columns(1)) Is Nothing Then
With Worksheets("BdD")
R = Application.Match(Target, .Range("A:A"), 0)
If Not IsError(R) Then
Set Rg = .Range("A" & R)
Else
On Error GoTo 0
For Each Sh In Shapes
If Not Intersect(Sh.TopLeftCell, Target.Offset(, 1)) Is
Nothing ThenSh.Delete
Exit Sub
End If
Next
End If
For Each Sh In .Shapes
If Not Intersect(Sh.TopLeftCell, Rg.Offset(, 1)) Is
Nothing ThenOn Error Resume Next
Shapes("Picture " & Split(Sh.Name, " ")(1)).Delete
On Error GoTo 0
Sh.Copy
ActiveSheet.Paste
Set S = Selection
Set Rg = Target.Offset(, 1)
With Rg
Largeur = .Offset(, 1)(, .Columns.Count).Left -
.LeftHauteur = .Offset(.Rows.Count).Top -
.Item(1).Top
End With
With S
.Name = Sh.Name
.Left = Rg.Left
.Top = Rg.Top
'Largeur de l'image
S.Width = Largeur
'Hauteur de l'image
S.Height = Hauteur
'Est-ce que l'image doit se déplacer avec les
cellules'voici les 3 constantes possibles
.Placement = xlFreeFloating 'or xlmove or
xlMoveAndSize'Verrouillé ou pas
.Locked = True 'or False
End With
Rg.Offset(, 1).Select
End If
Next
End With
End If
Set Rg = Nothing: Set Sh = Nothing: Set S = Nothing
End Sub
'-------------------------------------
Salutations!
"aife1" a écrit dans le message de
news:%Bonjour à tous !!
Je sais que cette question a déjà été posée, mais les réponses ne
correspondent pas exactement à mes attentes.
Dans un classeur, j'ai deux feuilles : BdD et Résultats.
La feuille BdD comporte une base de données qui se présente de la façon
suivante :
colonne A : nom du film
colonne B : image du film
colonne C : genre du film
colonne D : acteurs du film
...
Si dans la feuille Résultats je tape, dans la colonne A, le nom d'un
film
qui se trouve dans la base de données, je voudrais que l'image se place
automatiquement en colonne B; le genre en colonne C, ...
Pour le texte, j'y arrive, c'est juste pour l'image.
A savoir que certains films ne comportent pas d'image et que dans la
colonneA de la feuille Résultats, il peut y avoir un ou plusieurs films.
Merci d'avance pour vos conseils ...
Bonjour Michdenis !
Tout d'abord, un très grand merci pour ton aide.
Ton code marche, mais il y une "erreur d'exécution 1004 : La méthode
'Intersect' de l'objet_Global a échoué" au niveau de la ligne suivante :
If Not Intersect(Sh.TopLeftCell, Target.Offset(, 1)) Is
Nothing Then
A part cela, l'image se copie à merveille.
C'est ce que je comprend pas (je m'y connais pas trop en VBA), malgré
l'erreur, ça marche ! On ne pourrait pas mettre dans le code un truc qui
fermerait la boîte d'erreur ?
Merci encore ...
"michdenis" <michdenis@hotmail.com> a écrit dans le message de
news:uCqhXlxfEHA.3932@TK2MSFTNGP09.phx.gbl...
Re-Bonjour,
En supplément, modifie les 2 premières lignes de code par ceci :
If Not Intersect(Target, Columns(1)) Is Nothing Then
If Target.Rows.Count > 1 Then Exit Sub 'Celle-ci est nouvelle
Attention, à la disposition de tes images en Colonne B de ta feuille
BdD.
La procédure est basée sur la propriété TopLeftCell
d'un objet Range en l'occurrence dans le présent cas, des images. Si ton
image n'est pas méticuleusement placée en colonne B
et qu'elle empiète sur la colonne A de quelques millimètres ... la
procédure ne s'exécutera pas adéquatement ...Donc avant de
copier la procédure assure-toi de l'emplacement de tes images !!!
Salutations!
"michdenis" <michdenis@hotmail.com> a écrit dans le message de
news:OxKjzbxfEHA.2764@TK2MSFTNGP11.phx.gbl...
Bonjour aife1,
Copie le code suivant dans le module code de ta feuille "Résultats" et
tu
pries !
'-------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rg As Range, Sh As Shape, R As Variant, S As Object
If Not Intersect(Target, Columns(1)) Is Nothing Then
With Worksheets("BdD")
R = Application.Match(Target, .Range("A:A"), 0)
If Not IsError(R) Then
Set Rg = .Range("A" & R)
Else
On Error GoTo 0
For Each Sh In Shapes
If Not Intersect(Sh.TopLeftCell, Target.Offset(, 1)) Is
Nothing Then
Sh.Delete
Exit Sub
End If
Next
End If
For Each Sh In .Shapes
If Not Intersect(Sh.TopLeftCell, Rg.Offset(, 1)) Is
Nothing Then
On Error Resume Next
Shapes("Picture " & Split(Sh.Name, " ")(1)).Delete
On Error GoTo 0
Sh.Copy
ActiveSheet.Paste
Set S = Selection
Set Rg = Target.Offset(, 1)
With Rg
Largeur = .Offset(, 1)(, .Columns.Count).Left -
.Left
Hauteur = .Offset(.Rows.Count).Top -
.Item(1).Top
End With
With S
.Name = Sh.Name
.Left = Rg.Left
.Top = Rg.Top
'Largeur de l'image
S.Width = Largeur
'Hauteur de l'image
S.Height = Hauteur
'Est-ce que l'image doit se déplacer avec les
cellules
'voici les 3 constantes possibles
.Placement = xlFreeFloating 'or xlmove or
xlMoveAndSize
'Verrouillé ou pas
.Locked = True 'or False
End With
Rg.Offset(, 1).Select
End If
Next
End With
End If
Set Rg = Nothing: Set Sh = Nothing: Set S = Nothing
End Sub
'-------------------------------------
Salutations!
"aife1" <aife1@wanadoo.fr> a écrit dans le message de
news:%23UizZUrfEHA.3536@TK2MSFTNGP12.phx.gbl...
Bonjour à tous !!
Je sais que cette question a déjà été posée, mais les réponses ne
correspondent pas exactement à mes attentes.
Dans un classeur, j'ai deux feuilles : BdD et Résultats.
La feuille BdD comporte une base de données qui se présente de la façon
suivante :
colonne A : nom du film
colonne B : image du film
colonne C : genre du film
colonne D : acteurs du film
...
Si dans la feuille Résultats je tape, dans la colonne A, le nom d'un
film
qui se trouve dans la base de données, je voudrais que l'image se place
automatiquement en colonne B; le genre en colonne C, ...
Pour le texte, j'y arrive, c'est juste pour l'image.
A savoir que certains films ne comportent pas d'image et que dans la
colonne
A de la feuille Résultats, il peut y avoir un ou plusieurs films.
Merci d'avance pour vos conseils ...
Bonjour Michdenis !
Tout d'abord, un très grand merci pour ton aide.
Ton code marche, mais il y une "erreur d'exécution 1004 : La méthode
'Intersect' de l'objet_Global a échoué" au niveau de la ligne suivante :If Not Intersect(Sh.TopLeftCell, Target.Offset(, 1)) Is
Nothing Then
A part cela, l'image se copie à merveille.
C'est ce que je comprend pas (je m'y connais pas trop en VBA), malgré
l'erreur, ça marche ! On ne pourrait pas mettre dans le code un truc qui
fermerait la boîte d'erreur ?
Merci encore ...
"michdenis" a écrit dans le message de
news:Re-Bonjour,
En supplément, modifie les 2 premières lignes de code par ceci :
If Not Intersect(Target, Columns(1)) Is Nothing Then
If Target.Rows.Count > 1 Then Exit Sub 'Celle-ci est nouvelle
Attention, à la disposition de tes images en Colonne B de ta feuille
BdD.
La procédure est basée sur la propriété TopLeftCelld'un objet Range en l'occurrence dans le présent cas, des images. Si ton
image n'est pas méticuleusement placée en colonne Bet qu'elle empiète sur la colonne A de quelques millimètres ... la
procédure ne s'exécutera pas adéquatement ...Donc avant decopier la procédure assure-toi de l'emplacement de tes images !!!
Salutations!
"michdenis" a écrit dans le message de
news:Bonjour aife1,
Copie le code suivant dans le module code de ta feuille "Résultats" et
tu
pries !
'-------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rg As Range, Sh As Shape, R As Variant, S As Object
If Not Intersect(Target, Columns(1)) Is Nothing Then
With Worksheets("BdD")
R = Application.Match(Target, .Range("A:A"), 0)
If Not IsError(R) Then
Set Rg = .Range("A" & R)
Else
On Error GoTo 0
For Each Sh In Shapes
If Not Intersect(Sh.TopLeftCell, Target.Offset(, 1)) Is
Nothing ThenSh.Delete
Exit Sub
End If
Next
End If
For Each Sh In .Shapes
If Not Intersect(Sh.TopLeftCell, Rg.Offset(, 1)) Is
Nothing ThenOn Error Resume Next
Shapes("Picture " & Split(Sh.Name, " ")(1)).Delete
On Error GoTo 0
Sh.Copy
ActiveSheet.Paste
Set S = Selection
Set Rg = Target.Offset(, 1)
With Rg
Largeur = .Offset(, 1)(, .Columns.Count).Left -
.LeftHauteur = .Offset(.Rows.Count).Top -
.Item(1).Top
End With
With S
.Name = Sh.Name
.Left = Rg.Left
.Top = Rg.Top
'Largeur de l'image
S.Width = Largeur
'Hauteur de l'image
S.Height = Hauteur
'Est-ce que l'image doit se déplacer avec les
cellules'voici les 3 constantes possibles
.Placement = xlFreeFloating 'or xlmove or
xlMoveAndSize'Verrouillé ou pas
.Locked = True 'or False
End With
Rg.Offset(, 1).Select
End If
Next
End With
End If
Set Rg = Nothing: Set Sh = Nothing: Set S = Nothing
End Sub
'-------------------------------------
Salutations!
"aife1" a écrit dans le message de
news:%Bonjour à tous !!
Je sais que cette question a déjà été posée, mais les réponses ne
correspondent pas exactement à mes attentes.
Dans un classeur, j'ai deux feuilles : BdD et Résultats.
La feuille BdD comporte une base de données qui se présente de la façon
suivante :
colonne A : nom du film
colonne B : image du film
colonne C : genre du film
colonne D : acteurs du film
...
Si dans la feuille Résultats je tape, dans la colonne A, le nom d'un
film
qui se trouve dans la base de données, je voudrais que l'image se place
automatiquement en colonne B; le genre en colonne C, ...
Pour le texte, j'y arrive, c'est juste pour l'image.
A savoir que certains films ne comportent pas d'image et que dans la
colonneA de la feuille Résultats, il peut y avoir un ou plusieurs films.
Merci d'avance pour vos conseils ...
Bonjour Michdenis !
Tout d'abord, un très grand merci pour ton aide.
Ton code marche, mais il y une "erreur d'exécution 1004 : La méthode
'Intersect' de l'objet_Global a échoué" au niveau de la ligne suivante :If Not Intersect(Sh.TopLeftCell, Target.Offset(, 1)) Is
Nothing Then
A part cela, l'image se copie à merveille.
C'est ce que je comprend pas (je m'y connais pas trop en VBA), malgré
l'erreur, ça marche ! On ne pourrait pas mettre dans le code un truc qui
fermerait la boîte d'erreur ?
Merci encore ...
"michdenis" a écrit dans le message de
news:Re-Bonjour,
En supplément, modifie les 2 premières lignes de code par ceci :
If Not Intersect(Target, Columns(1)) Is Nothing Then
If Target.Rows.Count > 1 Then Exit Sub 'Celle-ci est nouvelle
Attention, à la disposition de tes images en Colonne B de ta feuille
BdD.
La procédure est basée sur la propriété TopLeftCelld'un objet Range en l'occurrence dans le présent cas, des images. Si ton
image n'est pas méticuleusement placée en colonne Bet qu'elle empiète sur la colonne A de quelques millimètres ... la
procédure ne s'exécutera pas adéquatement ...Donc avant decopier la procédure assure-toi de l'emplacement de tes images !!!
Salutations!
"michdenis" a écrit dans le message de
news:Bonjour aife1,
Copie le code suivant dans le module code de ta feuille "Résultats" et
tu
pries !
'-------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rg As Range, Sh As Shape, R As Variant, S As Object
If Not Intersect(Target, Columns(1)) Is Nothing Then
With Worksheets("BdD")
R = Application.Match(Target, .Range("A:A"), 0)
If Not IsError(R) Then
Set Rg = .Range("A" & R)
Else
On Error GoTo 0
For Each Sh In Shapes
If Not Intersect(Sh.TopLeftCell, Target.Offset(, 1)) Is
Nothing ThenSh.Delete
Exit Sub
End If
Next
End If
For Each Sh In .Shapes
If Not Intersect(Sh.TopLeftCell, Rg.Offset(, 1)) Is
Nothing ThenOn Error Resume Next
Shapes("Picture " & Split(Sh.Name, " ")(1)).Delete
On Error GoTo 0
Sh.Copy
ActiveSheet.Paste
Set S = Selection
Set Rg = Target.Offset(, 1)
With Rg
Largeur = .Offset(, 1)(, .Columns.Count).Left -
.LeftHauteur = .Offset(.Rows.Count).Top -
.Item(1).Top
End With
With S
.Name = Sh.Name
.Left = Rg.Left
.Top = Rg.Top
'Largeur de l'image
S.Width = Largeur
'Hauteur de l'image
S.Height = Hauteur
'Est-ce que l'image doit se déplacer avec les
cellules'voici les 3 constantes possibles
.Placement = xlFreeFloating 'or xlmove or
xlMoveAndSize'Verrouillé ou pas
.Locked = True 'or False
End With
Rg.Offset(, 1).Select
End If
Next
End With
End If
Set Rg = Nothing: Set Sh = Nothing: Set S = Nothing
End Sub
'-------------------------------------
Salutations!
"aife1" a écrit dans le message de
news:%Bonjour à tous !!
Je sais que cette question a déjà été posée, mais les réponses ne
correspondent pas exactement à mes attentes.
Dans un classeur, j'ai deux feuilles : BdD et Résultats.
La feuille BdD comporte une base de données qui se présente de la façon
suivante :
colonne A : nom du film
colonne B : image du film
colonne C : genre du film
colonne D : acteurs du film
...
Si dans la feuille Résultats je tape, dans la colonne A, le nom d'un
film
qui se trouve dans la base de données, je voudrais que l'image se place
automatiquement en colonne B; le genre en colonne C, ...
Pour le texte, j'y arrive, c'est juste pour l'image.
A savoir que certains films ne comportent pas d'image et que dans la
colonneA de la feuille Résultats, il peut y avoir un ou plusieurs films.
Merci d'avance pour vos conseils ...
Bonjour Michdenis !
Tout d'abord, un très grand merci pour ton aide.
Ton code marche, mais il y une "erreur d'exécution 1004 : La méthode
'Intersect' de l'objet_Global a échoué" au niveau de la ligne suivante :
If Not Intersect(Sh.TopLeftCell, Target.Offset(, 1)) Is
Nothing Then
A part cela, l'image se copie à merveille.
C'est ce que je comprend pas (je m'y connais pas trop en VBA), malgré
l'erreur, ça marche ! On ne pourrait pas mettre dans le code un truc qui
fermerait la boîte d'erreur ?
Merci encore ...
"michdenis" <michdenis@hotmail.com> a écrit dans le message de
news:uCqhXlxfEHA.3932@TK2MSFTNGP09.phx.gbl...
Re-Bonjour,
En supplément, modifie les 2 premières lignes de code par ceci :
If Not Intersect(Target, Columns(1)) Is Nothing Then
If Target.Rows.Count > 1 Then Exit Sub 'Celle-ci est nouvelle
Attention, à la disposition de tes images en Colonne B de ta feuille
BdD.
La procédure est basée sur la propriété TopLeftCell
d'un objet Range en l'occurrence dans le présent cas, des images. Si ton
image n'est pas méticuleusement placée en colonne B
et qu'elle empiète sur la colonne A de quelques millimètres ... la
procédure ne s'exécutera pas adéquatement ...Donc avant de
copier la procédure assure-toi de l'emplacement de tes images !!!
Salutations!
"michdenis" <michdenis@hotmail.com> a écrit dans le message de
news:OxKjzbxfEHA.2764@TK2MSFTNGP11.phx.gbl...
Bonjour aife1,
Copie le code suivant dans le module code de ta feuille "Résultats" et
tu
pries !
'-------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rg As Range, Sh As Shape, R As Variant, S As Object
If Not Intersect(Target, Columns(1)) Is Nothing Then
With Worksheets("BdD")
R = Application.Match(Target, .Range("A:A"), 0)
If Not IsError(R) Then
Set Rg = .Range("A" & R)
Else
On Error GoTo 0
For Each Sh In Shapes
If Not Intersect(Sh.TopLeftCell, Target.Offset(, 1)) Is
Nothing Then
Sh.Delete
Exit Sub
End If
Next
End If
For Each Sh In .Shapes
If Not Intersect(Sh.TopLeftCell, Rg.Offset(, 1)) Is
Nothing Then
On Error Resume Next
Shapes("Picture " & Split(Sh.Name, " ")(1)).Delete
On Error GoTo 0
Sh.Copy
ActiveSheet.Paste
Set S = Selection
Set Rg = Target.Offset(, 1)
With Rg
Largeur = .Offset(, 1)(, .Columns.Count).Left -
.Left
Hauteur = .Offset(.Rows.Count).Top -
.Item(1).Top
End With
With S
.Name = Sh.Name
.Left = Rg.Left
.Top = Rg.Top
'Largeur de l'image
S.Width = Largeur
'Hauteur de l'image
S.Height = Hauteur
'Est-ce que l'image doit se déplacer avec les
cellules
'voici les 3 constantes possibles
.Placement = xlFreeFloating 'or xlmove or
xlMoveAndSize
'Verrouillé ou pas
.Locked = True 'or False
End With
Rg.Offset(, 1).Select
End If
Next
End With
End If
Set Rg = Nothing: Set Sh = Nothing: Set S = Nothing
End Sub
'-------------------------------------
Salutations!
"aife1" <aife1@wanadoo.fr> a écrit dans le message de
news:%23UizZUrfEHA.3536@TK2MSFTNGP12.phx.gbl...
Bonjour à tous !!
Je sais que cette question a déjà été posée, mais les réponses ne
correspondent pas exactement à mes attentes.
Dans un classeur, j'ai deux feuilles : BdD et Résultats.
La feuille BdD comporte une base de données qui se présente de la façon
suivante :
colonne A : nom du film
colonne B : image du film
colonne C : genre du film
colonne D : acteurs du film
...
Si dans la feuille Résultats je tape, dans la colonne A, le nom d'un
film
qui se trouve dans la base de données, je voudrais que l'image se place
automatiquement en colonne B; le genre en colonne C, ...
Pour le texte, j'y arrive, c'est juste pour l'image.
A savoir que certains films ne comportent pas d'image et que dans la
colonne
A de la feuille Résultats, il peut y avoir un ou plusieurs films.
Merci d'avance pour vos conseils ...
Bonjour Michdenis !
Tout d'abord, un très grand merci pour ton aide.
Ton code marche, mais il y une "erreur d'exécution 1004 : La méthode
'Intersect' de l'objet_Global a échoué" au niveau de la ligne suivante :If Not Intersect(Sh.TopLeftCell, Target.Offset(, 1)) Is
Nothing Then
A part cela, l'image se copie à merveille.
C'est ce que je comprend pas (je m'y connais pas trop en VBA), malgré
l'erreur, ça marche ! On ne pourrait pas mettre dans le code un truc qui
fermerait la boîte d'erreur ?
Merci encore ...
"michdenis" a écrit dans le message de
news:Re-Bonjour,
En supplément, modifie les 2 premières lignes de code par ceci :
If Not Intersect(Target, Columns(1)) Is Nothing Then
If Target.Rows.Count > 1 Then Exit Sub 'Celle-ci est nouvelle
Attention, à la disposition de tes images en Colonne B de ta feuille
BdD.
La procédure est basée sur la propriété TopLeftCelld'un objet Range en l'occurrence dans le présent cas, des images. Si ton
image n'est pas méticuleusement placée en colonne Bet qu'elle empiète sur la colonne A de quelques millimètres ... la
procédure ne s'exécutera pas adéquatement ...Donc avant decopier la procédure assure-toi de l'emplacement de tes images !!!
Salutations!
"michdenis" a écrit dans le message de
news:Bonjour aife1,
Copie le code suivant dans le module code de ta feuille "Résultats" et
tu
pries !
'-------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rg As Range, Sh As Shape, R As Variant, S As Object
If Not Intersect(Target, Columns(1)) Is Nothing Then
With Worksheets("BdD")
R = Application.Match(Target, .Range("A:A"), 0)
If Not IsError(R) Then
Set Rg = .Range("A" & R)
Else
On Error GoTo 0
For Each Sh In Shapes
If Not Intersect(Sh.TopLeftCell, Target.Offset(, 1)) Is
Nothing ThenSh.Delete
Exit Sub
End If
Next
End If
For Each Sh In .Shapes
If Not Intersect(Sh.TopLeftCell, Rg.Offset(, 1)) Is
Nothing ThenOn Error Resume Next
Shapes("Picture " & Split(Sh.Name, " ")(1)).Delete
On Error GoTo 0
Sh.Copy
ActiveSheet.Paste
Set S = Selection
Set Rg = Target.Offset(, 1)
With Rg
Largeur = .Offset(, 1)(, .Columns.Count).Left -
.LeftHauteur = .Offset(.Rows.Count).Top -
.Item(1).Top
End With
With S
.Name = Sh.Name
.Left = Rg.Left
.Top = Rg.Top
'Largeur de l'image
S.Width = Largeur
'Hauteur de l'image
S.Height = Hauteur
'Est-ce que l'image doit se déplacer avec les
cellules'voici les 3 constantes possibles
.Placement = xlFreeFloating 'or xlmove or
xlMoveAndSize'Verrouillé ou pas
.Locked = True 'or False
End With
Rg.Offset(, 1).Select
End If
Next
End With
End If
Set Rg = Nothing: Set Sh = Nothing: Set S = Nothing
End Sub
'-------------------------------------
Salutations!
"aife1" a écrit dans le message de
news:%Bonjour à tous !!
Je sais que cette question a déjà été posée, mais les réponses ne
correspondent pas exactement à mes attentes.
Dans un classeur, j'ai deux feuilles : BdD et Résultats.
La feuille BdD comporte une base de données qui se présente de la façon
suivante :
colonne A : nom du film
colonne B : image du film
colonne C : genre du film
colonne D : acteurs du film
...
Si dans la feuille Résultats je tape, dans la colonne A, le nom d'un
film
qui se trouve dans la base de données, je voudrais que l'image se place
automatiquement en colonne B; le genre en colonne C, ...
Pour le texte, j'y arrive, c'est juste pour l'image.
A savoir que certains films ne comportent pas d'image et que dans la
colonneA de la feuille Résultats, il peut y avoir un ou plusieurs films.
Merci d'avance pour vos conseils ...
Bonjour Aife1,
Essaie ceci :
'-----------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rg As Range, Sh As Shape, R As Variant, S As Object
If Not Intersect(Target, Columns(1)) Is Nothing Then
On Error Resume Next
With Worksheets("BdD")
If .Shapes.Count = 0 Then
For Each Sh In Shapes
Sh.Delete
Next
Exit Sub
End If
R = Application.Match(Target, .Range("A:A"), 0)
If IsError(R) Then
On Error GoTo 0
If Shapes.Count = 0 Then Exit Sub
For Each Sh In Shapes
If Not Intersect(Sh.TopLeftCell, Target.Offset(, 1)) Is
Nothing Then
Sh.Delete
Exit Sub
End If
Next
Else
Set Rg = .Range("A" & R)
End If
For Each Sh In .Shapes
If Not Intersect(Sh.TopLeftCell, Rg.Offset(, 1)) Is
Nothing Then
Shapes(Split(Sh.Name, " ")(0) & " " &
Target.Row).Delete
On Error GoTo 0
Sh.Copy
ActiveSheet.Paste
Set S = Selection
Set Rg = Target.Offset(, 1)
With Rg
Largeur = .Offset(, 1)(, .Columns.Count).Left -
.Left
Hauteur = .Offset(.Rows.Count).Top - .Item(1).Top
End With
With S
.Name = Split(Sh.Name, " ")(0) & " " & Target.Row
.Left = Rg.Left
.Top = Rg.Top
'Largeur de l'image
S.Width = Largeur
'Hauteur de l'image
S.Height = Hauteur
'Est-ce que l'image doit se déplacer avec les
cellules
'voici les 3 constantes possibles
.Placement = xlFreeFloating 'or xlmove or
xlMoveAndSize
'Verrouillé ou pas
.Locked = True 'or False
End With
Rg.Offset(, 1).Select
Else
Shapes("Picture " & Split(Sh.Name, " ")(1)).Delete
On Error GoTo 0
End If
Next
End With
End If
Set Rg = Nothing: Set Sh = Nothing: Set S = Nothing
End Sub
'-----------------------------------------
Salutations!
"aife1" a écrit dans le message de
news:
Excuse-moi, je me suis trompée dans la ligne d'erreur, il s'agit de :
If Not Intersect(Sh.TopLeftCell, Rg.Offset(, 1)) Is Nothing Then
Toutes mes excuses.
Amicalement
"aife1" a écrit dans le message de
news:O5r5%Bonjour Michdenis !
Tout d'abord, un très grand merci pour ton aide.
Ton code marche, mais il y une "erreur d'exécution 1004 : La méthode
'Intersect' de l'objet_Global a échoué" au niveau de la ligne suivante :If Not Intersect(Sh.TopLeftCell, Target.Offset(, 1))
Is
Nothing Then
A part cela, l'image se copie à merveille.
C'est ce que je comprend pas (je m'y connais pas trop en VBA), malgré
l'erreur, ça marche ! On ne pourrait pas mettre dans le code un truc qui
fermerait la boîte d'erreur ?
Merci encore ...
"michdenis" a écrit dans le message de
news:Re-Bonjour,
En supplément, modifie les 2 premières lignes de code par ceci :
If Not Intersect(Target, Columns(1)) Is Nothing Then
If Target.Rows.Count > 1 Then Exit Sub 'Celle-ci est nouvelle
Attention, à la disposition de tes images en Colonne B de ta feuille
BdD.La procédure est basée sur la propriété TopLeftCelld'un objet Range en l'occurrence dans le présent cas, des images. Si
ton
image n'est pas méticuleusement placée en colonne Bet qu'elle empiète sur la colonne A de quelques millimètres ... la
procédure ne s'exécutera pas adéquatement ...Donc avant decopier la procédure assure-toi de l'emplacement de tes images !!!
Salutations!
"michdenis" a écrit dans le message de
news:Bonjour aife1,
Copie le code suivant dans le module code de ta feuille "Résultats" et
tupries !
'-------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rg As Range, Sh As Shape, R As Variant, S As Object
If Not Intersect(Target, Columns(1)) Is Nothing Then
With Worksheets("BdD")
R = Application.Match(Target, .Range("A:A"), 0)
If Not IsError(R) Then
Set Rg = .Range("A" & R)
Else
On Error GoTo 0
For Each Sh In Shapes
If Not Intersect(Sh.TopLeftCell, Target.Offset(, 1))
Is
Nothing ThenSh.Delete
Exit Sub
End If
Next
End If
For Each Sh In .Shapes
If Not Intersect(Sh.TopLeftCell, Rg.Offset(, 1)) Is
Nothing ThenOn Error Resume Next
Shapes("Picture " & Split(Sh.Name, " ")(1)).Delete
On Error GoTo 0
Sh.Copy
ActiveSheet.Paste
Set S = Selection
Set Rg = Target.Offset(, 1)
With Rg
Largeur = .Offset(, 1)(,
.Columns.Count).Left -
.LeftHauteur = .Offset(.Rows.Count).Top -
.Item(1).TopEnd With
With S
.Name = Sh.Name
.Left = Rg.Left
.Top = Rg.Top
'Largeur de l'image
S.Width = Largeur
'Hauteur de l'image
S.Height = Hauteur
'Est-ce que l'image doit se déplacer avec les
cellules'voici les 3 constantes possibles
.Placement = xlFreeFloating 'or xlmove or
xlMoveAndSize'Verrouillé ou pas
.Locked = True 'or False
End With
Rg.Offset(, 1).Select
End If
Next
End With
End If
Set Rg = Nothing: Set Sh = Nothing: Set S = Nothing
End Sub
'-------------------------------------
Salutations!
"aife1" a écrit dans le message de
news:%Bonjour à tous !!
Je sais que cette question a déjà été posée, mais les réponses ne
correspondent pas exactement à mes attentes.
Dans un classeur, j'ai deux feuilles : BdD et Résultats.
La feuille BdD comporte une base de données qui se présente de la
façon
suivante :
colonne A : nom du film
colonne B : image du film
colonne C : genre du film
colonne D : acteurs du film
...
Si dans la feuille Résultats je tape, dans la colonne A, le nom d'un
filmqui se trouve dans la base de données, je voudrais que l'image se
place
automatiquement en colonne B; le genre en colonne C, ...
Pour le texte, j'y arrive, c'est juste pour l'image.
A savoir que certains films ne comportent pas d'image et que dans la
colonneA de la feuille Résultats, il peut y avoir un ou plusieurs films.
Merci d'avance pour vos conseils ...
Bonjour Aife1,
Essaie ceci :
'-----------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rg As Range, Sh As Shape, R As Variant, S As Object
If Not Intersect(Target, Columns(1)) Is Nothing Then
On Error Resume Next
With Worksheets("BdD")
If .Shapes.Count = 0 Then
For Each Sh In Shapes
Sh.Delete
Next
Exit Sub
End If
R = Application.Match(Target, .Range("A:A"), 0)
If IsError(R) Then
On Error GoTo 0
If Shapes.Count = 0 Then Exit Sub
For Each Sh In Shapes
If Not Intersect(Sh.TopLeftCell, Target.Offset(, 1)) Is
Nothing Then
Sh.Delete
Exit Sub
End If
Next
Else
Set Rg = .Range("A" & R)
End If
For Each Sh In .Shapes
If Not Intersect(Sh.TopLeftCell, Rg.Offset(, 1)) Is
Nothing Then
Shapes(Split(Sh.Name, " ")(0) & " " &
Target.Row).Delete
On Error GoTo 0
Sh.Copy
ActiveSheet.Paste
Set S = Selection
Set Rg = Target.Offset(, 1)
With Rg
Largeur = .Offset(, 1)(, .Columns.Count).Left -
.Left
Hauteur = .Offset(.Rows.Count).Top - .Item(1).Top
End With
With S
.Name = Split(Sh.Name, " ")(0) & " " & Target.Row
.Left = Rg.Left
.Top = Rg.Top
'Largeur de l'image
S.Width = Largeur
'Hauteur de l'image
S.Height = Hauteur
'Est-ce que l'image doit se déplacer avec les
cellules
'voici les 3 constantes possibles
.Placement = xlFreeFloating 'or xlmove or
xlMoveAndSize
'Verrouillé ou pas
.Locked = True 'or False
End With
Rg.Offset(, 1).Select
Else
Shapes("Picture " & Split(Sh.Name, " ")(1)).Delete
On Error GoTo 0
End If
Next
End With
End If
Set Rg = Nothing: Set Sh = Nothing: Set S = Nothing
End Sub
'-----------------------------------------
Salutations!
"aife1" <aife1@wanadoo.fr> a écrit dans le message de
news:u2HhBF4fEHA.3632@TK2MSFTNGP11.phx.gbl...
Excuse-moi, je me suis trompée dans la ligne d'erreur, il s'agit de :
If Not Intersect(Sh.TopLeftCell, Rg.Offset(, 1)) Is Nothing Then
Toutes mes excuses.
Amicalement
"aife1" <aife1@wanadoo.fr> a écrit dans le message de
news:O5r5%23q3fEHA.2896@TK2MSFTNGP11.phx.gbl...
Bonjour Michdenis !
Tout d'abord, un très grand merci pour ton aide.
Ton code marche, mais il y une "erreur d'exécution 1004 : La méthode
'Intersect' de l'objet_Global a échoué" au niveau de la ligne suivante :
If Not Intersect(Sh.TopLeftCell, Target.Offset(, 1))
Is
Nothing Then
A part cela, l'image se copie à merveille.
C'est ce que je comprend pas (je m'y connais pas trop en VBA), malgré
l'erreur, ça marche ! On ne pourrait pas mettre dans le code un truc qui
fermerait la boîte d'erreur ?
Merci encore ...
"michdenis" <michdenis@hotmail.com> a écrit dans le message de
news:uCqhXlxfEHA.3932@TK2MSFTNGP09.phx.gbl...
Re-Bonjour,
En supplément, modifie les 2 premières lignes de code par ceci :
If Not Intersect(Target, Columns(1)) Is Nothing Then
If Target.Rows.Count > 1 Then Exit Sub 'Celle-ci est nouvelle
Attention, à la disposition de tes images en Colonne B de ta feuille
BdD.
La procédure est basée sur la propriété TopLeftCell
d'un objet Range en l'occurrence dans le présent cas, des images. Si
ton
image n'est pas méticuleusement placée en colonne B
et qu'elle empiète sur la colonne A de quelques millimètres ... la
procédure ne s'exécutera pas adéquatement ...Donc avant de
copier la procédure assure-toi de l'emplacement de tes images !!!
Salutations!
"michdenis" <michdenis@hotmail.com> a écrit dans le message de
news:OxKjzbxfEHA.2764@TK2MSFTNGP11.phx.gbl...
Bonjour aife1,
Copie le code suivant dans le module code de ta feuille "Résultats" et
tu
pries !
'-------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rg As Range, Sh As Shape, R As Variant, S As Object
If Not Intersect(Target, Columns(1)) Is Nothing Then
With Worksheets("BdD")
R = Application.Match(Target, .Range("A:A"), 0)
If Not IsError(R) Then
Set Rg = .Range("A" & R)
Else
On Error GoTo 0
For Each Sh In Shapes
If Not Intersect(Sh.TopLeftCell, Target.Offset(, 1))
Is
Nothing Then
Sh.Delete
Exit Sub
End If
Next
End If
For Each Sh In .Shapes
If Not Intersect(Sh.TopLeftCell, Rg.Offset(, 1)) Is
Nothing Then
On Error Resume Next
Shapes("Picture " & Split(Sh.Name, " ")(1)).Delete
On Error GoTo 0
Sh.Copy
ActiveSheet.Paste
Set S = Selection
Set Rg = Target.Offset(, 1)
With Rg
Largeur = .Offset(, 1)(,
.Columns.Count).Left -
.Left
Hauteur = .Offset(.Rows.Count).Top -
.Item(1).Top
End With
With S
.Name = Sh.Name
.Left = Rg.Left
.Top = Rg.Top
'Largeur de l'image
S.Width = Largeur
'Hauteur de l'image
S.Height = Hauteur
'Est-ce que l'image doit se déplacer avec les
cellules
'voici les 3 constantes possibles
.Placement = xlFreeFloating 'or xlmove or
xlMoveAndSize
'Verrouillé ou pas
.Locked = True 'or False
End With
Rg.Offset(, 1).Select
End If
Next
End With
End If
Set Rg = Nothing: Set Sh = Nothing: Set S = Nothing
End Sub
'-------------------------------------
Salutations!
"aife1" <aife1@wanadoo.fr> a écrit dans le message de
news:%23UizZUrfEHA.3536@TK2MSFTNGP12.phx.gbl...
Bonjour à tous !!
Je sais que cette question a déjà été posée, mais les réponses ne
correspondent pas exactement à mes attentes.
Dans un classeur, j'ai deux feuilles : BdD et Résultats.
La feuille BdD comporte une base de données qui se présente de la
façon
suivante :
colonne A : nom du film
colonne B : image du film
colonne C : genre du film
colonne D : acteurs du film
...
Si dans la feuille Résultats je tape, dans la colonne A, le nom d'un
film
qui se trouve dans la base de données, je voudrais que l'image se
place
automatiquement en colonne B; le genre en colonne C, ...
Pour le texte, j'y arrive, c'est juste pour l'image.
A savoir que certains films ne comportent pas d'image et que dans la
colonne
A de la feuille Résultats, il peut y avoir un ou plusieurs films.
Merci d'avance pour vos conseils ...
Bonjour Aife1,
Essaie ceci :
'-----------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rg As Range, Sh As Shape, R As Variant, S As Object
If Not Intersect(Target, Columns(1)) Is Nothing Then
On Error Resume Next
With Worksheets("BdD")
If .Shapes.Count = 0 Then
For Each Sh In Shapes
Sh.Delete
Next
Exit Sub
End If
R = Application.Match(Target, .Range("A:A"), 0)
If IsError(R) Then
On Error GoTo 0
If Shapes.Count = 0 Then Exit Sub
For Each Sh In Shapes
If Not Intersect(Sh.TopLeftCell, Target.Offset(, 1)) Is
Nothing Then
Sh.Delete
Exit Sub
End If
Next
Else
Set Rg = .Range("A" & R)
End If
For Each Sh In .Shapes
If Not Intersect(Sh.TopLeftCell, Rg.Offset(, 1)) Is
Nothing Then
Shapes(Split(Sh.Name, " ")(0) & " " &
Target.Row).Delete
On Error GoTo 0
Sh.Copy
ActiveSheet.Paste
Set S = Selection
Set Rg = Target.Offset(, 1)
With Rg
Largeur = .Offset(, 1)(, .Columns.Count).Left -
.Left
Hauteur = .Offset(.Rows.Count).Top - .Item(1).Top
End With
With S
.Name = Split(Sh.Name, " ")(0) & " " & Target.Row
.Left = Rg.Left
.Top = Rg.Top
'Largeur de l'image
S.Width = Largeur
'Hauteur de l'image
S.Height = Hauteur
'Est-ce que l'image doit se déplacer avec les
cellules
'voici les 3 constantes possibles
.Placement = xlFreeFloating 'or xlmove or
xlMoveAndSize
'Verrouillé ou pas
.Locked = True 'or False
End With
Rg.Offset(, 1).Select
Else
Shapes("Picture " & Split(Sh.Name, " ")(1)).Delete
On Error GoTo 0
End If
Next
End With
End If
Set Rg = Nothing: Set Sh = Nothing: Set S = Nothing
End Sub
'-----------------------------------------
Salutations!
"aife1" a écrit dans le message de
news:
Excuse-moi, je me suis trompée dans la ligne d'erreur, il s'agit de :
If Not Intersect(Sh.TopLeftCell, Rg.Offset(, 1)) Is Nothing Then
Toutes mes excuses.
Amicalement
"aife1" a écrit dans le message de
news:O5r5%Bonjour Michdenis !
Tout d'abord, un très grand merci pour ton aide.
Ton code marche, mais il y une "erreur d'exécution 1004 : La méthode
'Intersect' de l'objet_Global a échoué" au niveau de la ligne suivante :If Not Intersect(Sh.TopLeftCell, Target.Offset(, 1))
Is
Nothing Then
A part cela, l'image se copie à merveille.
C'est ce que je comprend pas (je m'y connais pas trop en VBA), malgré
l'erreur, ça marche ! On ne pourrait pas mettre dans le code un truc qui
fermerait la boîte d'erreur ?
Merci encore ...
"michdenis" a écrit dans le message de
news:Re-Bonjour,
En supplément, modifie les 2 premières lignes de code par ceci :
If Not Intersect(Target, Columns(1)) Is Nothing Then
If Target.Rows.Count > 1 Then Exit Sub 'Celle-ci est nouvelle
Attention, à la disposition de tes images en Colonne B de ta feuille
BdD.La procédure est basée sur la propriété TopLeftCelld'un objet Range en l'occurrence dans le présent cas, des images. Si
ton
image n'est pas méticuleusement placée en colonne Bet qu'elle empiète sur la colonne A de quelques millimètres ... la
procédure ne s'exécutera pas adéquatement ...Donc avant decopier la procédure assure-toi de l'emplacement de tes images !!!
Salutations!
"michdenis" a écrit dans le message de
news:Bonjour aife1,
Copie le code suivant dans le module code de ta feuille "Résultats" et
tupries !
'-------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rg As Range, Sh As Shape, R As Variant, S As Object
If Not Intersect(Target, Columns(1)) Is Nothing Then
With Worksheets("BdD")
R = Application.Match(Target, .Range("A:A"), 0)
If Not IsError(R) Then
Set Rg = .Range("A" & R)
Else
On Error GoTo 0
For Each Sh In Shapes
If Not Intersect(Sh.TopLeftCell, Target.Offset(, 1))
Is
Nothing ThenSh.Delete
Exit Sub
End If
Next
End If
For Each Sh In .Shapes
If Not Intersect(Sh.TopLeftCell, Rg.Offset(, 1)) Is
Nothing ThenOn Error Resume Next
Shapes("Picture " & Split(Sh.Name, " ")(1)).Delete
On Error GoTo 0
Sh.Copy
ActiveSheet.Paste
Set S = Selection
Set Rg = Target.Offset(, 1)
With Rg
Largeur = .Offset(, 1)(,
.Columns.Count).Left -
.LeftHauteur = .Offset(.Rows.Count).Top -
.Item(1).TopEnd With
With S
.Name = Sh.Name
.Left = Rg.Left
.Top = Rg.Top
'Largeur de l'image
S.Width = Largeur
'Hauteur de l'image
S.Height = Hauteur
'Est-ce que l'image doit se déplacer avec les
cellules'voici les 3 constantes possibles
.Placement = xlFreeFloating 'or xlmove or
xlMoveAndSize'Verrouillé ou pas
.Locked = True 'or False
End With
Rg.Offset(, 1).Select
End If
Next
End With
End If
Set Rg = Nothing: Set Sh = Nothing: Set S = Nothing
End Sub
'-------------------------------------
Salutations!
"aife1" a écrit dans le message de
news:%Bonjour à tous !!
Je sais que cette question a déjà été posée, mais les réponses ne
correspondent pas exactement à mes attentes.
Dans un classeur, j'ai deux feuilles : BdD et Résultats.
La feuille BdD comporte une base de données qui se présente de la
façon
suivante :
colonne A : nom du film
colonne B : image du film
colonne C : genre du film
colonne D : acteurs du film
...
Si dans la feuille Résultats je tape, dans la colonne A, le nom d'un
filmqui se trouve dans la base de données, je voudrais que l'image se
place
automatiquement en colonne B; le genre en colonne C, ...
Pour le texte, j'y arrive, c'est juste pour l'image.
A savoir que certains films ne comportent pas d'image et que dans la
colonneA de la feuille Résultats, il peut y avoir un ou plusieurs films.
Merci d'avance pour vos conseils ...
Bonjour Michdenis !
Tout d'abord, un très grand merci pour ton aide.
Ton code marche, mais il y une "erreur d'exécution 1004 : La méthode
'Intersect' de l'objet_Global a échoué" au niveau de la ligne suivante :If Not Intersect(Sh.TopLeftCell, Target.Offset(, 1)) Is
Nothing Then
A part cela, l'image se copie à merveille.
C'est ce que je comprend pas (je m'y connais pas trop en VBA), malgré
l'erreur, ça marche ! On ne pourrait pas mettre dans le code un truc qui
fermerait la boîte d'erreur ?
Merci encore ...
"michdenis" a écrit dans le message de
news:Re-Bonjour,
En supplément, modifie les 2 premières lignes de code par ceci :
If Not Intersect(Target, Columns(1)) Is Nothing Then
If Target.Rows.Count > 1 Then Exit Sub 'Celle-ci est nouvelle
Attention, à la disposition de tes images en Colonne B de ta feuille
BdD.
La procédure est basée sur la propriété TopLeftCelld'un objet Range en l'occurrence dans le présent cas, des images. Si ton
image n'est pas méticuleusement placée en colonne Bet qu'elle empiète sur la colonne A de quelques millimètres ... la
procédure ne s'exécutera pas adéquatement ...Donc avant decopier la procédure assure-toi de l'emplacement de tes images !!!
Salutations!
"michdenis" a écrit dans le message de
news:Bonjour aife1,
Copie le code suivant dans le module code de ta feuille "Résultats" et
tu
pries !
'-------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rg As Range, Sh As Shape, R As Variant, S As Object
If Not Intersect(Target, Columns(1)) Is Nothing Then
With Worksheets("BdD")
R = Application.Match(Target, .Range("A:A"), 0)
If Not IsError(R) Then
Set Rg = .Range("A" & R)
Else
On Error GoTo 0
For Each Sh In Shapes
If Not Intersect(Sh.TopLeftCell, Target.Offset(, 1)) Is
Nothing ThenSh.Delete
Exit Sub
End If
Next
End If
For Each Sh In .Shapes
If Not Intersect(Sh.TopLeftCell, Rg.Offset(, 1)) Is
Nothing ThenOn Error Resume Next
Shapes("Picture " & Split(Sh.Name, " ")(1)).Delete
On Error GoTo 0
Sh.Copy
ActiveSheet.Paste
Set S = Selection
Set Rg = Target.Offset(, 1)
With Rg
Largeur = .Offset(, 1)(, .Columns.Count).Left -
.LeftHauteur = .Offset(.Rows.Count).Top -
.Item(1).Top
End With
With S
.Name = Sh.Name
.Left = Rg.Left
.Top = Rg.Top
'Largeur de l'image
S.Width = Largeur
'Hauteur de l'image
S.Height = Hauteur
'Est-ce que l'image doit se déplacer avec les
cellules'voici les 3 constantes possibles
.Placement = xlFreeFloating 'or xlmove or
xlMoveAndSize'Verrouillé ou pas
.Locked = True 'or False
End With
Rg.Offset(, 1).Select
End If
Next
End With
End If
Set Rg = Nothing: Set Sh = Nothing: Set S = Nothing
End Sub
'-------------------------------------
Salutations!
"aife1" a écrit dans le message de
news:%Bonjour à tous !!
Je sais que cette question a déjà été posée, mais les réponses ne
correspondent pas exactement à mes attentes.
Dans un classeur, j'ai deux feuilles : BdD et Résultats.
La feuille BdD comporte une base de données qui se présente de la façon
suivante :
colonne A : nom du film
colonne B : image du film
colonne C : genre du film
colonne D : acteurs du film
...
Si dans la feuille Résultats je tape, dans la colonne A, le nom d'un
film
qui se trouve dans la base de données, je voudrais que l'image se place
automatiquement en colonne B; le genre en colonne C, ...
Pour le texte, j'y arrive, c'est juste pour l'image.
A savoir que certains films ne comportent pas d'image et que dans la
colonneA de la feuille Résultats, il peut y avoir un ou plusieurs films.
Merci d'avance pour vos conseils ...
Bonjour Michdenis !
Tout d'abord, un très grand merci pour ton aide.
Ton code marche, mais il y une "erreur d'exécution 1004 : La méthode
'Intersect' de l'objet_Global a échoué" au niveau de la ligne suivante :
If Not Intersect(Sh.TopLeftCell, Target.Offset(, 1)) Is
Nothing Then
A part cela, l'image se copie à merveille.
C'est ce que je comprend pas (je m'y connais pas trop en VBA), malgré
l'erreur, ça marche ! On ne pourrait pas mettre dans le code un truc qui
fermerait la boîte d'erreur ?
Merci encore ...
"michdenis" <michdenis@hotmail.com> a écrit dans le message de
news:uCqhXlxfEHA.3932@TK2MSFTNGP09.phx.gbl...
Re-Bonjour,
En supplément, modifie les 2 premières lignes de code par ceci :
If Not Intersect(Target, Columns(1)) Is Nothing Then
If Target.Rows.Count > 1 Then Exit Sub 'Celle-ci est nouvelle
Attention, à la disposition de tes images en Colonne B de ta feuille
BdD.
La procédure est basée sur la propriété TopLeftCell
d'un objet Range en l'occurrence dans le présent cas, des images. Si ton
image n'est pas méticuleusement placée en colonne B
et qu'elle empiète sur la colonne A de quelques millimètres ... la
procédure ne s'exécutera pas adéquatement ...Donc avant de
copier la procédure assure-toi de l'emplacement de tes images !!!
Salutations!
"michdenis" <michdenis@hotmail.com> a écrit dans le message de
news:OxKjzbxfEHA.2764@TK2MSFTNGP11.phx.gbl...
Bonjour aife1,
Copie le code suivant dans le module code de ta feuille "Résultats" et
tu
pries !
'-------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rg As Range, Sh As Shape, R As Variant, S As Object
If Not Intersect(Target, Columns(1)) Is Nothing Then
With Worksheets("BdD")
R = Application.Match(Target, .Range("A:A"), 0)
If Not IsError(R) Then
Set Rg = .Range("A" & R)
Else
On Error GoTo 0
For Each Sh In Shapes
If Not Intersect(Sh.TopLeftCell, Target.Offset(, 1)) Is
Nothing Then
Sh.Delete
Exit Sub
End If
Next
End If
For Each Sh In .Shapes
If Not Intersect(Sh.TopLeftCell, Rg.Offset(, 1)) Is
Nothing Then
On Error Resume Next
Shapes("Picture " & Split(Sh.Name, " ")(1)).Delete
On Error GoTo 0
Sh.Copy
ActiveSheet.Paste
Set S = Selection
Set Rg = Target.Offset(, 1)
With Rg
Largeur = .Offset(, 1)(, .Columns.Count).Left -
.Left
Hauteur = .Offset(.Rows.Count).Top -
.Item(1).Top
End With
With S
.Name = Sh.Name
.Left = Rg.Left
.Top = Rg.Top
'Largeur de l'image
S.Width = Largeur
'Hauteur de l'image
S.Height = Hauteur
'Est-ce que l'image doit se déplacer avec les
cellules
'voici les 3 constantes possibles
.Placement = xlFreeFloating 'or xlmove or
xlMoveAndSize
'Verrouillé ou pas
.Locked = True 'or False
End With
Rg.Offset(, 1).Select
End If
Next
End With
End If
Set Rg = Nothing: Set Sh = Nothing: Set S = Nothing
End Sub
'-------------------------------------
Salutations!
"aife1" <aife1@wanadoo.fr> a écrit dans le message de
news:%23UizZUrfEHA.3536@TK2MSFTNGP12.phx.gbl...
Bonjour à tous !!
Je sais que cette question a déjà été posée, mais les réponses ne
correspondent pas exactement à mes attentes.
Dans un classeur, j'ai deux feuilles : BdD et Résultats.
La feuille BdD comporte une base de données qui se présente de la façon
suivante :
colonne A : nom du film
colonne B : image du film
colonne C : genre du film
colonne D : acteurs du film
...
Si dans la feuille Résultats je tape, dans la colonne A, le nom d'un
film
qui se trouve dans la base de données, je voudrais que l'image se place
automatiquement en colonne B; le genre en colonne C, ...
Pour le texte, j'y arrive, c'est juste pour l'image.
A savoir que certains films ne comportent pas d'image et que dans la
colonne
A de la feuille Résultats, il peut y avoir un ou plusieurs films.
Merci d'avance pour vos conseils ...
Bonjour Michdenis !
Tout d'abord, un très grand merci pour ton aide.
Ton code marche, mais il y une "erreur d'exécution 1004 : La méthode
'Intersect' de l'objet_Global a échoué" au niveau de la ligne suivante :If Not Intersect(Sh.TopLeftCell, Target.Offset(, 1)) Is
Nothing Then
A part cela, l'image se copie à merveille.
C'est ce que je comprend pas (je m'y connais pas trop en VBA), malgré
l'erreur, ça marche ! On ne pourrait pas mettre dans le code un truc qui
fermerait la boîte d'erreur ?
Merci encore ...
"michdenis" a écrit dans le message de
news:Re-Bonjour,
En supplément, modifie les 2 premières lignes de code par ceci :
If Not Intersect(Target, Columns(1)) Is Nothing Then
If Target.Rows.Count > 1 Then Exit Sub 'Celle-ci est nouvelle
Attention, à la disposition de tes images en Colonne B de ta feuille
BdD.
La procédure est basée sur la propriété TopLeftCelld'un objet Range en l'occurrence dans le présent cas, des images. Si ton
image n'est pas méticuleusement placée en colonne Bet qu'elle empiète sur la colonne A de quelques millimètres ... la
procédure ne s'exécutera pas adéquatement ...Donc avant decopier la procédure assure-toi de l'emplacement de tes images !!!
Salutations!
"michdenis" a écrit dans le message de
news:Bonjour aife1,
Copie le code suivant dans le module code de ta feuille "Résultats" et
tu
pries !
'-------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rg As Range, Sh As Shape, R As Variant, S As Object
If Not Intersect(Target, Columns(1)) Is Nothing Then
With Worksheets("BdD")
R = Application.Match(Target, .Range("A:A"), 0)
If Not IsError(R) Then
Set Rg = .Range("A" & R)
Else
On Error GoTo 0
For Each Sh In Shapes
If Not Intersect(Sh.TopLeftCell, Target.Offset(, 1)) Is
Nothing ThenSh.Delete
Exit Sub
End If
Next
End If
For Each Sh In .Shapes
If Not Intersect(Sh.TopLeftCell, Rg.Offset(, 1)) Is
Nothing ThenOn Error Resume Next
Shapes("Picture " & Split(Sh.Name, " ")(1)).Delete
On Error GoTo 0
Sh.Copy
ActiveSheet.Paste
Set S = Selection
Set Rg = Target.Offset(, 1)
With Rg
Largeur = .Offset(, 1)(, .Columns.Count).Left -
.LeftHauteur = .Offset(.Rows.Count).Top -
.Item(1).Top
End With
With S
.Name = Sh.Name
.Left = Rg.Left
.Top = Rg.Top
'Largeur de l'image
S.Width = Largeur
'Hauteur de l'image
S.Height = Hauteur
'Est-ce que l'image doit se déplacer avec les
cellules'voici les 3 constantes possibles
.Placement = xlFreeFloating 'or xlmove or
xlMoveAndSize'Verrouillé ou pas
.Locked = True 'or False
End With
Rg.Offset(, 1).Select
End If
Next
End With
End If
Set Rg = Nothing: Set Sh = Nothing: Set S = Nothing
End Sub
'-------------------------------------
Salutations!
"aife1" a écrit dans le message de
news:%Bonjour à tous !!
Je sais que cette question a déjà été posée, mais les réponses ne
correspondent pas exactement à mes attentes.
Dans un classeur, j'ai deux feuilles : BdD et Résultats.
La feuille BdD comporte une base de données qui se présente de la façon
suivante :
colonne A : nom du film
colonne B : image du film
colonne C : genre du film
colonne D : acteurs du film
...
Si dans la feuille Résultats je tape, dans la colonne A, le nom d'un
film
qui se trouve dans la base de données, je voudrais que l'image se place
automatiquement en colonne B; le genre en colonne C, ...
Pour le texte, j'y arrive, c'est juste pour l'image.
A savoir que certains films ne comportent pas d'image et que dans la
colonneA de la feuille Résultats, il peut y avoir un ou plusieurs films.
Merci d'avance pour vos conseils ...
Légère correction :
Dans cette section de la procédure : Prend bonne note du nouvel
emplacement de la ligne de code EXIT SUB...tu devrais
modifier la procédure émise lors de mon récent message .
If IsError(R) Then
On Error GoTo 0
If Shapes.Count = 0 Then Exit Sub
For Each Sh In Shapes
If Not Intersect(Sh.TopLeftCell, Target.Offset(, 1)) Is
Nothing Then
Sh.Delete
End If
Next
Exit Sub
Else
Set Rg = .Range("A" & R)
End If
Salutations!
"michdenis" a écrit dans le message de
news:%
Bonjour Aife1,
Essaie ceci :
'-----------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rg As Range, Sh As Shape, R As Variant, S As Object
If Not Intersect(Target, Columns(1)) Is Nothing Then
On Error Resume Next
With Worksheets("BdD")
If .Shapes.Count = 0 Then
For Each Sh In Shapes
Sh.Delete
Next
Exit Sub
End If
R = Application.Match(Target, .Range("A:A"), 0)
If IsError(R) Then
On Error GoTo 0
If Shapes.Count = 0 Then Exit Sub
For Each Sh In Shapes
If Not Intersect(Sh.TopLeftCell, Target.Offset(, 1)) Is
Nothing Then
Sh.Delete
Exit Sub
End If
Next
Else
Set Rg = .Range("A" & R)
End If
For Each Sh In .Shapes
If Not Intersect(Sh.TopLeftCell, Rg.Offset(, 1)) Is
Nothing Then
Shapes(Split(Sh.Name, " ")(0) & " " &
Target.Row).Delete
On Error GoTo 0
Sh.Copy
ActiveSheet.Paste
Set S = Selection
Set Rg = Target.Offset(, 1)
With Rg
Largeur = .Offset(, 1)(, .Columns.Count).Left -
.Left
Hauteur = .Offset(.Rows.Count).Top - .Item(1).Top
End With
With S
.Name = Split(Sh.Name, " ")(0) & " " & Target.Row
.Left = Rg.Left
.Top = Rg.Top
'Largeur de l'image
S.Width = Largeur
'Hauteur de l'image
S.Height = Hauteur
'Est-ce que l'image doit se déplacer avec les
cellules
'voici les 3 constantes possibles
.Placement = xlFreeFloating 'or xlmove or
xlMoveAndSize
'Verrouillé ou pas
.Locked = True 'or False
End With
Rg.Offset(, 1).Select
Else
Shapes("Picture " & Split(Sh.Name, " ")(1)).Delete
On Error GoTo 0
End If
Next
End With
End If
Set Rg = Nothing: Set Sh = Nothing: Set S = Nothing
End Sub
'-----------------------------------------
Salutations!
"aife1" a écrit dans le message de
news:
Excuse-moi, je me suis trompée dans la ligne d'erreur, il s'agit de :
If Not Intersect(Sh.TopLeftCell, Rg.Offset(, 1)) Is Nothing Then
Toutes mes excuses.
Amicalement
"aife1" a écrit dans le message de
news:O5r5%Bonjour Michdenis !
Tout d'abord, un très grand merci pour ton aide.
Ton code marche, mais il y une "erreur d'exécution 1004 : La méthode
'Intersect' de l'objet_Global a échoué" au niveau de la ligne suivante :If Not Intersect(Sh.TopLeftCell, Target.Offset(, 1))
Is
Nothing Then
A part cela, l'image se copie à merveille.
C'est ce que je comprend pas (je m'y connais pas trop en VBA), malgré
l'erreur, ça marche ! On ne pourrait pas mettre dans le code un truc qui
fermerait la boîte d'erreur ?
Merci encore ...
"michdenis" a écrit dans le message de
news:Re-Bonjour,
En supplément, modifie les 2 premières lignes de code par ceci :
If Not Intersect(Target, Columns(1)) Is Nothing Then
If Target.Rows.Count > 1 Then Exit Sub 'Celle-ci est nouvelle
Attention, à la disposition de tes images en Colonne B de ta feuille
BdD.La procédure est basée sur la propriété TopLeftCelld'un objet Range en l'occurrence dans le présent cas, des images. Si
ton
image n'est pas méticuleusement placée en colonne Bet qu'elle empiète sur la colonne A de quelques millimètres ... la
procédure ne s'exécutera pas adéquatement ...Donc avant decopier la procédure assure-toi de l'emplacement de tes images !!!
Salutations!
"michdenis" a écrit dans le message de
news:Bonjour aife1,
Copie le code suivant dans le module code de ta feuille "Résultats" et
tupries !
'-------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rg As Range, Sh As Shape, R As Variant, S As Object
If Not Intersect(Target, Columns(1)) Is Nothing Then
With Worksheets("BdD")
R = Application.Match(Target, .Range("A:A"), 0)
If Not IsError(R) Then
Set Rg = .Range("A" & R)
Else
On Error GoTo 0
For Each Sh In Shapes
If Not Intersect(Sh.TopLeftCell, Target.Offset(, 1))
Is
Nothing ThenSh.Delete
Exit Sub
End If
Next
End If
For Each Sh In .Shapes
If Not Intersect(Sh.TopLeftCell, Rg.Offset(, 1)) Is
Nothing ThenOn Error Resume Next
Shapes("Picture " & Split(Sh.Name, " ")(1)).Delete
On Error GoTo 0
Sh.Copy
ActiveSheet.Paste
Set S = Selection
Set Rg = Target.Offset(, 1)
With Rg
Largeur = .Offset(, 1)(,
.Columns.Count).Left -
.LeftHauteur = .Offset(.Rows.Count).Top -
.Item(1).TopEnd With
With S
.Name = Sh.Name
.Left = Rg.Left
.Top = Rg.Top
'Largeur de l'image
S.Width = Largeur
'Hauteur de l'image
S.Height = Hauteur
'Est-ce que l'image doit se déplacer avec les
cellules'voici les 3 constantes possibles
.Placement = xlFreeFloating 'or xlmove or
xlMoveAndSize'Verrouillé ou pas
.Locked = True 'or False
End With
Rg.Offset(, 1).Select
End If
Next
End With
End If
Set Rg = Nothing: Set Sh = Nothing: Set S = Nothing
End Sub
'-------------------------------------
Salutations!
"aife1" a écrit dans le message de
news:%Bonjour à tous !!
Je sais que cette question a déjà été posée, mais les réponses ne
correspondent pas exactement à mes attentes.
Dans un classeur, j'ai deux feuilles : BdD et Résultats.
La feuille BdD comporte une base de données qui se présente de la
façon
suivante :
colonne A : nom du film
colonne B : image du film
colonne C : genre du film
colonne D : acteurs du film
...
Si dans la feuille Résultats je tape, dans la colonne A, le nom d'un
filmqui se trouve dans la base de données, je voudrais que l'image se
place
automatiquement en colonne B; le genre en colonne C, ...
Pour le texte, j'y arrive, c'est juste pour l'image.
A savoir que certains films ne comportent pas d'image et que dans la
colonneA de la feuille Résultats, il peut y avoir un ou plusieurs films.
Merci d'avance pour vos conseils ...
Légère correction :
Dans cette section de la procédure : Prend bonne note du nouvel
emplacement de la ligne de code EXIT SUB...tu devrais
modifier la procédure émise lors de mon récent message .
If IsError(R) Then
On Error GoTo 0
If Shapes.Count = 0 Then Exit Sub
For Each Sh In Shapes
If Not Intersect(Sh.TopLeftCell, Target.Offset(, 1)) Is
Nothing Then
Sh.Delete
End If
Next
Exit Sub
Else
Set Rg = .Range("A" & R)
End If
Salutations!
"michdenis" <michdenis@hotmail.com> a écrit dans le message de
news:%23bXRWI6fEHA.2544@TK2MSFTNGP10.phx.gbl...
Bonjour Aife1,
Essaie ceci :
'-----------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rg As Range, Sh As Shape, R As Variant, S As Object
If Not Intersect(Target, Columns(1)) Is Nothing Then
On Error Resume Next
With Worksheets("BdD")
If .Shapes.Count = 0 Then
For Each Sh In Shapes
Sh.Delete
Next
Exit Sub
End If
R = Application.Match(Target, .Range("A:A"), 0)
If IsError(R) Then
On Error GoTo 0
If Shapes.Count = 0 Then Exit Sub
For Each Sh In Shapes
If Not Intersect(Sh.TopLeftCell, Target.Offset(, 1)) Is
Nothing Then
Sh.Delete
Exit Sub
End If
Next
Else
Set Rg = .Range("A" & R)
End If
For Each Sh In .Shapes
If Not Intersect(Sh.TopLeftCell, Rg.Offset(, 1)) Is
Nothing Then
Shapes(Split(Sh.Name, " ")(0) & " " &
Target.Row).Delete
On Error GoTo 0
Sh.Copy
ActiveSheet.Paste
Set S = Selection
Set Rg = Target.Offset(, 1)
With Rg
Largeur = .Offset(, 1)(, .Columns.Count).Left -
.Left
Hauteur = .Offset(.Rows.Count).Top - .Item(1).Top
End With
With S
.Name = Split(Sh.Name, " ")(0) & " " & Target.Row
.Left = Rg.Left
.Top = Rg.Top
'Largeur de l'image
S.Width = Largeur
'Hauteur de l'image
S.Height = Hauteur
'Est-ce que l'image doit se déplacer avec les
cellules
'voici les 3 constantes possibles
.Placement = xlFreeFloating 'or xlmove or
xlMoveAndSize
'Verrouillé ou pas
.Locked = True 'or False
End With
Rg.Offset(, 1).Select
Else
Shapes("Picture " & Split(Sh.Name, " ")(1)).Delete
On Error GoTo 0
End If
Next
End With
End If
Set Rg = Nothing: Set Sh = Nothing: Set S = Nothing
End Sub
'-----------------------------------------
Salutations!
"aife1" <aife1@wanadoo.fr> a écrit dans le message de
news:u2HhBF4fEHA.3632@TK2MSFTNGP11.phx.gbl...
Excuse-moi, je me suis trompée dans la ligne d'erreur, il s'agit de :
If Not Intersect(Sh.TopLeftCell, Rg.Offset(, 1)) Is Nothing Then
Toutes mes excuses.
Amicalement
"aife1" <aife1@wanadoo.fr> a écrit dans le message de
news:O5r5%23q3fEHA.2896@TK2MSFTNGP11.phx.gbl...
Bonjour Michdenis !
Tout d'abord, un très grand merci pour ton aide.
Ton code marche, mais il y une "erreur d'exécution 1004 : La méthode
'Intersect' de l'objet_Global a échoué" au niveau de la ligne suivante :
If Not Intersect(Sh.TopLeftCell, Target.Offset(, 1))
Is
Nothing Then
A part cela, l'image se copie à merveille.
C'est ce que je comprend pas (je m'y connais pas trop en VBA), malgré
l'erreur, ça marche ! On ne pourrait pas mettre dans le code un truc qui
fermerait la boîte d'erreur ?
Merci encore ...
"michdenis" <michdenis@hotmail.com> a écrit dans le message de
news:uCqhXlxfEHA.3932@TK2MSFTNGP09.phx.gbl...
Re-Bonjour,
En supplément, modifie les 2 premières lignes de code par ceci :
If Not Intersect(Target, Columns(1)) Is Nothing Then
If Target.Rows.Count > 1 Then Exit Sub 'Celle-ci est nouvelle
Attention, à la disposition de tes images en Colonne B de ta feuille
BdD.
La procédure est basée sur la propriété TopLeftCell
d'un objet Range en l'occurrence dans le présent cas, des images. Si
ton
image n'est pas méticuleusement placée en colonne B
et qu'elle empiète sur la colonne A de quelques millimètres ... la
procédure ne s'exécutera pas adéquatement ...Donc avant de
copier la procédure assure-toi de l'emplacement de tes images !!!
Salutations!
"michdenis" <michdenis@hotmail.com> a écrit dans le message de
news:OxKjzbxfEHA.2764@TK2MSFTNGP11.phx.gbl...
Bonjour aife1,
Copie le code suivant dans le module code de ta feuille "Résultats" et
tu
pries !
'-------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rg As Range, Sh As Shape, R As Variant, S As Object
If Not Intersect(Target, Columns(1)) Is Nothing Then
With Worksheets("BdD")
R = Application.Match(Target, .Range("A:A"), 0)
If Not IsError(R) Then
Set Rg = .Range("A" & R)
Else
On Error GoTo 0
For Each Sh In Shapes
If Not Intersect(Sh.TopLeftCell, Target.Offset(, 1))
Is
Nothing Then
Sh.Delete
Exit Sub
End If
Next
End If
For Each Sh In .Shapes
If Not Intersect(Sh.TopLeftCell, Rg.Offset(, 1)) Is
Nothing Then
On Error Resume Next
Shapes("Picture " & Split(Sh.Name, " ")(1)).Delete
On Error GoTo 0
Sh.Copy
ActiveSheet.Paste
Set S = Selection
Set Rg = Target.Offset(, 1)
With Rg
Largeur = .Offset(, 1)(,
.Columns.Count).Left -
.Left
Hauteur = .Offset(.Rows.Count).Top -
.Item(1).Top
End With
With S
.Name = Sh.Name
.Left = Rg.Left
.Top = Rg.Top
'Largeur de l'image
S.Width = Largeur
'Hauteur de l'image
S.Height = Hauteur
'Est-ce que l'image doit se déplacer avec les
cellules
'voici les 3 constantes possibles
.Placement = xlFreeFloating 'or xlmove or
xlMoveAndSize
'Verrouillé ou pas
.Locked = True 'or False
End With
Rg.Offset(, 1).Select
End If
Next
End With
End If
Set Rg = Nothing: Set Sh = Nothing: Set S = Nothing
End Sub
'-------------------------------------
Salutations!
"aife1" <aife1@wanadoo.fr> a écrit dans le message de
news:%23UizZUrfEHA.3536@TK2MSFTNGP12.phx.gbl...
Bonjour à tous !!
Je sais que cette question a déjà été posée, mais les réponses ne
correspondent pas exactement à mes attentes.
Dans un classeur, j'ai deux feuilles : BdD et Résultats.
La feuille BdD comporte une base de données qui se présente de la
façon
suivante :
colonne A : nom du film
colonne B : image du film
colonne C : genre du film
colonne D : acteurs du film
...
Si dans la feuille Résultats je tape, dans la colonne A, le nom d'un
film
qui se trouve dans la base de données, je voudrais que l'image se
place
automatiquement en colonne B; le genre en colonne C, ...
Pour le texte, j'y arrive, c'est juste pour l'image.
A savoir que certains films ne comportent pas d'image et que dans la
colonne
A de la feuille Résultats, il peut y avoir un ou plusieurs films.
Merci d'avance pour vos conseils ...
Légère correction :
Dans cette section de la procédure : Prend bonne note du nouvel
emplacement de la ligne de code EXIT SUB...tu devrais
modifier la procédure émise lors de mon récent message .
If IsError(R) Then
On Error GoTo 0
If Shapes.Count = 0 Then Exit Sub
For Each Sh In Shapes
If Not Intersect(Sh.TopLeftCell, Target.Offset(, 1)) Is
Nothing Then
Sh.Delete
End If
Next
Exit Sub
Else
Set Rg = .Range("A" & R)
End If
Salutations!
"michdenis" a écrit dans le message de
news:%
Bonjour Aife1,
Essaie ceci :
'-----------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rg As Range, Sh As Shape, R As Variant, S As Object
If Not Intersect(Target, Columns(1)) Is Nothing Then
On Error Resume Next
With Worksheets("BdD")
If .Shapes.Count = 0 Then
For Each Sh In Shapes
Sh.Delete
Next
Exit Sub
End If
R = Application.Match(Target, .Range("A:A"), 0)
If IsError(R) Then
On Error GoTo 0
If Shapes.Count = 0 Then Exit Sub
For Each Sh In Shapes
If Not Intersect(Sh.TopLeftCell, Target.Offset(, 1)) Is
Nothing Then
Sh.Delete
Exit Sub
End If
Next
Else
Set Rg = .Range("A" & R)
End If
For Each Sh In .Shapes
If Not Intersect(Sh.TopLeftCell, Rg.Offset(, 1)) Is
Nothing Then
Shapes(Split(Sh.Name, " ")(0) & " " &
Target.Row).Delete
On Error GoTo 0
Sh.Copy
ActiveSheet.Paste
Set S = Selection
Set Rg = Target.Offset(, 1)
With Rg
Largeur = .Offset(, 1)(, .Columns.Count).Left -
.Left
Hauteur = .Offset(.Rows.Count).Top - .Item(1).Top
End With
With S
.Name = Split(Sh.Name, " ")(0) & " " & Target.Row
.Left = Rg.Left
.Top = Rg.Top
'Largeur de l'image
S.Width = Largeur
'Hauteur de l'image
S.Height = Hauteur
'Est-ce que l'image doit se déplacer avec les
cellules
'voici les 3 constantes possibles
.Placement = xlFreeFloating 'or xlmove or
xlMoveAndSize
'Verrouillé ou pas
.Locked = True 'or False
End With
Rg.Offset(, 1).Select
Else
Shapes("Picture " & Split(Sh.Name, " ")(1)).Delete
On Error GoTo 0
End If
Next
End With
End If
Set Rg = Nothing: Set Sh = Nothing: Set S = Nothing
End Sub
'-----------------------------------------
Salutations!
"aife1" a écrit dans le message de
news:
Excuse-moi, je me suis trompée dans la ligne d'erreur, il s'agit de :
If Not Intersect(Sh.TopLeftCell, Rg.Offset(, 1)) Is Nothing Then
Toutes mes excuses.
Amicalement
"aife1" a écrit dans le message de
news:O5r5%Bonjour Michdenis !
Tout d'abord, un très grand merci pour ton aide.
Ton code marche, mais il y une "erreur d'exécution 1004 : La méthode
'Intersect' de l'objet_Global a échoué" au niveau de la ligne suivante :If Not Intersect(Sh.TopLeftCell, Target.Offset(, 1))
Is
Nothing Then
A part cela, l'image se copie à merveille.
C'est ce que je comprend pas (je m'y connais pas trop en VBA), malgré
l'erreur, ça marche ! On ne pourrait pas mettre dans le code un truc qui
fermerait la boîte d'erreur ?
Merci encore ...
"michdenis" a écrit dans le message de
news:Re-Bonjour,
En supplément, modifie les 2 premières lignes de code par ceci :
If Not Intersect(Target, Columns(1)) Is Nothing Then
If Target.Rows.Count > 1 Then Exit Sub 'Celle-ci est nouvelle
Attention, à la disposition de tes images en Colonne B de ta feuille
BdD.La procédure est basée sur la propriété TopLeftCelld'un objet Range en l'occurrence dans le présent cas, des images. Si
ton
image n'est pas méticuleusement placée en colonne Bet qu'elle empiète sur la colonne A de quelques millimètres ... la
procédure ne s'exécutera pas adéquatement ...Donc avant decopier la procédure assure-toi de l'emplacement de tes images !!!
Salutations!
"michdenis" a écrit dans le message de
news:Bonjour aife1,
Copie le code suivant dans le module code de ta feuille "Résultats" et
tupries !
'-------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rg As Range, Sh As Shape, R As Variant, S As Object
If Not Intersect(Target, Columns(1)) Is Nothing Then
With Worksheets("BdD")
R = Application.Match(Target, .Range("A:A"), 0)
If Not IsError(R) Then
Set Rg = .Range("A" & R)
Else
On Error GoTo 0
For Each Sh In Shapes
If Not Intersect(Sh.TopLeftCell, Target.Offset(, 1))
Is
Nothing ThenSh.Delete
Exit Sub
End If
Next
End If
For Each Sh In .Shapes
If Not Intersect(Sh.TopLeftCell, Rg.Offset(, 1)) Is
Nothing ThenOn Error Resume Next
Shapes("Picture " & Split(Sh.Name, " ")(1)).Delete
On Error GoTo 0
Sh.Copy
ActiveSheet.Paste
Set S = Selection
Set Rg = Target.Offset(, 1)
With Rg
Largeur = .Offset(, 1)(,
.Columns.Count).Left -
.LeftHauteur = .Offset(.Rows.Count).Top -
.Item(1).TopEnd With
With S
.Name = Sh.Name
.Left = Rg.Left
.Top = Rg.Top
'Largeur de l'image
S.Width = Largeur
'Hauteur de l'image
S.Height = Hauteur
'Est-ce que l'image doit se déplacer avec les
cellules'voici les 3 constantes possibles
.Placement = xlFreeFloating 'or xlmove or
xlMoveAndSize'Verrouillé ou pas
.Locked = True 'or False
End With
Rg.Offset(, 1).Select
End If
Next
End With
End If
Set Rg = Nothing: Set Sh = Nothing: Set S = Nothing
End Sub
'-------------------------------------
Salutations!
"aife1" a écrit dans le message de
news:%Bonjour à tous !!
Je sais que cette question a déjà été posée, mais les réponses ne
correspondent pas exactement à mes attentes.
Dans un classeur, j'ai deux feuilles : BdD et Résultats.
La feuille BdD comporte une base de données qui se présente de la
façon
suivante :
colonne A : nom du film
colonne B : image du film
colonne C : genre du film
colonne D : acteurs du film
...
Si dans la feuille Résultats je tape, dans la colonne A, le nom d'un
filmqui se trouve dans la base de données, je voudrais que l'image se
place
automatiquement en colonne B; le genre en colonne C, ...
Pour le texte, j'y arrive, c'est juste pour l'image.
A savoir que certains films ne comportent pas d'image et que dans la
colonneA de la feuille Résultats, il peut y avoir un ou plusieurs films.
Merci d'avance pour vos conseils ...
Légère correction :
Dans cette section de la procédure : Prend bonne note du nouvel
emplacement de la ligne de code EXIT SUB...tu devrais
modifier la procédure émise lors de mon récent message .
If IsError(R) Then
On Error GoTo 0
If Shapes.Count = 0 Then Exit Sub
For Each Sh In Shapes
If Not Intersect(Sh.TopLeftCell, Target.Offset(, 1)) Is
Nothing Then
Sh.Delete
End If
Next
Exit Sub
Else
Set Rg = .Range("A" & R)
End If
Salutations!
"michdenis" a écrit dans le message de
news:%
Bonjour Aife1,
Essaie ceci :
'-----------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rg As Range, Sh As Shape, R As Variant, S As Object
If Not Intersect(Target, Columns(1)) Is Nothing Then
On Error Resume Next
With Worksheets("BdD")
If .Shapes.Count = 0 Then
For Each Sh In Shapes
Sh.Delete
Next
Exit Sub
End If
R = Application.Match(Target, .Range("A:A"), 0)
If IsError(R) Then
On Error GoTo 0
If Shapes.Count = 0 Then Exit Sub
For Each Sh In Shapes
If Not Intersect(Sh.TopLeftCell, Target.Offset(, 1)) Is
Nothing Then
Sh.Delete
Exit Sub
End If
Next
Else
Set Rg = .Range("A" & R)
End If
For Each Sh In .Shapes
If Not Intersect(Sh.TopLeftCell, Rg.Offset(, 1)) Is
Nothing Then
Shapes(Split(Sh.Name, " ")(0) & " " &
Target.Row).Delete
On Error GoTo 0
Sh.Copy
ActiveSheet.Paste
Set S = Selection
Set Rg = Target.Offset(, 1)
With Rg
Largeur = .Offset(, 1)(, .Columns.Count).Left -
.Left
Hauteur = .Offset(.Rows.Count).Top - .Item(1).Top
End With
With S
.Name = Split(Sh.Name, " ")(0) & " " & Target.Row
.Left = Rg.Left
.Top = Rg.Top
'Largeur de l'image
S.Width = Largeur
'Hauteur de l'image
S.Height = Hauteur
'Est-ce que l'image doit se déplacer avec les
cellules
'voici les 3 constantes possibles
.Placement = xlFreeFloating 'or xlmove or
xlMoveAndSize
'Verrouillé ou pas
.Locked = True 'or False
End With
Rg.Offset(, 1).Select
Else
Shapes("Picture " & Split(Sh.Name, " ")(1)).Delete
On Error GoTo 0
End If
Next
End With
End If
Set Rg = Nothing: Set Sh = Nothing: Set S = Nothing
End Sub
'-----------------------------------------
Salutations!
"aife1" a écrit dans le message de
news:
Excuse-moi, je me suis trompée dans la ligne d'erreur, il s'agit de :
If Not Intersect(Sh.TopLeftCell, Rg.Offset(, 1)) Is Nothing Then
Toutes mes excuses.
Amicalement
"aife1" a écrit dans le message de
news:O5r5%Bonjour Michdenis !
Tout d'abord, un très grand merci pour ton aide.
Ton code marche, mais il y une "erreur d'exécution 1004 : La méthode
'Intersect' de l'objet_Global a échoué" au niveau de la ligne suivante :If Not Intersect(Sh.TopLeftCell, Target.Offset(, 1))
Is
Nothing Then
A part cela, l'image se copie à merveille.
C'est ce que je comprend pas (je m'y connais pas trop en VBA), malgré
l'erreur, ça marche ! On ne pourrait pas mettre dans le code un truc qui
fermerait la boîte d'erreur ?
Merci encore ...
"michdenis" a écrit dans le message de
news:Re-Bonjour,
En supplément, modifie les 2 premières lignes de code par ceci :
If Not Intersect(Target, Columns(1)) Is Nothing Then
If Target.Rows.Count > 1 Then Exit Sub 'Celle-ci est nouvelle
Attention, à la disposition de tes images en Colonne B de ta feuille
BdD.La procédure est basée sur la propriété TopLeftCelld'un objet Range en l'occurrence dans le présent cas, des images. Si
ton
image n'est pas méticuleusement placée en colonne Bet qu'elle empiète sur la colonne A de quelques millimètres ... la
procédure ne s'exécutera pas adéquatement ...Donc avant decopier la procédure assure-toi de l'emplacement de tes images !!!
Salutations!
"michdenis" a écrit dans le message de
news:Bonjour aife1,
Copie le code suivant dans le module code de ta feuille "Résultats" et
tupries !
'-------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rg As Range, Sh As Shape, R As Variant, S As Object
If Not Intersect(Target, Columns(1)) Is Nothing Then
With Worksheets("BdD")
R = Application.Match(Target, .Range("A:A"), 0)
If Not IsError(R) Then
Set Rg = .Range("A" & R)
Else
On Error GoTo 0
For Each Sh In Shapes
If Not Intersect(Sh.TopLeftCell, Target.Offset(, 1))
Is
Nothing ThenSh.Delete
Exit Sub
End If
Next
End If
For Each Sh In .Shapes
If Not Intersect(Sh.TopLeftCell, Rg.Offset(, 1)) Is
Nothing ThenOn Error Resume Next
Shapes("Picture " & Split(Sh.Name, " ")(1)).Delete
On Error GoTo 0
Sh.Copy
ActiveSheet.Paste
Set S = Selection
Set Rg = Target.Offset(, 1)
With Rg
Largeur = .Offset(, 1)(,
.Columns.Count).Left -
.LeftHauteur = .Offset(.Rows.Count).Top -
.Item(1).TopEnd With
With S
.Name = Sh.Name
.Left = Rg.Left
.Top = Rg.Top
'Largeur de l'image
S.Width = Largeur
'Hauteur de l'image
S.Height = Hauteur
'Est-ce que l'image doit se déplacer avec les
cellules'voici les 3 constantes possibles
.Placement = xlFreeFloating 'or xlmove or
xlMoveAndSize'Verrouillé ou pas
.Locked = True 'or False
End With
Rg.Offset(, 1).Select
End If
Next
End With
End If
Set Rg = Nothing: Set Sh = Nothing: Set S = Nothing
End Sub
'-------------------------------------
Salutations!
"aife1" a écrit dans le message de
news:%Bonjour à tous !!
Je sais que cette question a déjà été posée, mais les réponses ne
correspondent pas exactement à mes attentes.
Dans un classeur, j'ai deux feuilles : BdD et Résultats.
La feuille BdD comporte une base de données qui se présente de la
façon
suivante :
colonne A : nom du film
colonne B : image du film
colonne C : genre du film
colonne D : acteurs du film
...
Si dans la feuille Résultats je tape, dans la colonne A, le nom d'un
filmqui se trouve dans la base de données, je voudrais que l'image se
place
automatiquement en colonne B; le genre en colonne C, ...
Pour le texte, j'y arrive, c'est juste pour l'image.
A savoir que certains films ne comportent pas d'image et que dans la
colonneA de la feuille Résultats, il peut y avoir un ou plusieurs films.
Merci d'avance pour vos conseils ...
Légère correction :
Dans cette section de la procédure : Prend bonne note du nouvel
emplacement de la ligne de code EXIT SUB...tu devrais
modifier la procédure émise lors de mon récent message .
If IsError(R) Then
On Error GoTo 0
If Shapes.Count = 0 Then Exit Sub
For Each Sh In Shapes
If Not Intersect(Sh.TopLeftCell, Target.Offset(, 1)) Is
Nothing Then
Sh.Delete
End If
Next
Exit Sub
Else
Set Rg = .Range("A" & R)
End If
Salutations!
"michdenis" <michdenis@hotmail.com> a écrit dans le message de
news:%23bXRWI6fEHA.2544@TK2MSFTNGP10.phx.gbl...
Bonjour Aife1,
Essaie ceci :
'-----------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rg As Range, Sh As Shape, R As Variant, S As Object
If Not Intersect(Target, Columns(1)) Is Nothing Then
On Error Resume Next
With Worksheets("BdD")
If .Shapes.Count = 0 Then
For Each Sh In Shapes
Sh.Delete
Next
Exit Sub
End If
R = Application.Match(Target, .Range("A:A"), 0)
If IsError(R) Then
On Error GoTo 0
If Shapes.Count = 0 Then Exit Sub
For Each Sh In Shapes
If Not Intersect(Sh.TopLeftCell, Target.Offset(, 1)) Is
Nothing Then
Sh.Delete
Exit Sub
End If
Next
Else
Set Rg = .Range("A" & R)
End If
For Each Sh In .Shapes
If Not Intersect(Sh.TopLeftCell, Rg.Offset(, 1)) Is
Nothing Then
Shapes(Split(Sh.Name, " ")(0) & " " &
Target.Row).Delete
On Error GoTo 0
Sh.Copy
ActiveSheet.Paste
Set S = Selection
Set Rg = Target.Offset(, 1)
With Rg
Largeur = .Offset(, 1)(, .Columns.Count).Left -
.Left
Hauteur = .Offset(.Rows.Count).Top - .Item(1).Top
End With
With S
.Name = Split(Sh.Name, " ")(0) & " " & Target.Row
.Left = Rg.Left
.Top = Rg.Top
'Largeur de l'image
S.Width = Largeur
'Hauteur de l'image
S.Height = Hauteur
'Est-ce que l'image doit se déplacer avec les
cellules
'voici les 3 constantes possibles
.Placement = xlFreeFloating 'or xlmove or
xlMoveAndSize
'Verrouillé ou pas
.Locked = True 'or False
End With
Rg.Offset(, 1).Select
Else
Shapes("Picture " & Split(Sh.Name, " ")(1)).Delete
On Error GoTo 0
End If
Next
End With
End If
Set Rg = Nothing: Set Sh = Nothing: Set S = Nothing
End Sub
'-----------------------------------------
Salutations!
"aife1" <aife1@wanadoo.fr> a écrit dans le message de
news:u2HhBF4fEHA.3632@TK2MSFTNGP11.phx.gbl...
Excuse-moi, je me suis trompée dans la ligne d'erreur, il s'agit de :
If Not Intersect(Sh.TopLeftCell, Rg.Offset(, 1)) Is Nothing Then
Toutes mes excuses.
Amicalement
"aife1" <aife1@wanadoo.fr> a écrit dans le message de
news:O5r5%23q3fEHA.2896@TK2MSFTNGP11.phx.gbl...
Bonjour Michdenis !
Tout d'abord, un très grand merci pour ton aide.
Ton code marche, mais il y une "erreur d'exécution 1004 : La méthode
'Intersect' de l'objet_Global a échoué" au niveau de la ligne suivante :
If Not Intersect(Sh.TopLeftCell, Target.Offset(, 1))
Is
Nothing Then
A part cela, l'image se copie à merveille.
C'est ce que je comprend pas (je m'y connais pas trop en VBA), malgré
l'erreur, ça marche ! On ne pourrait pas mettre dans le code un truc qui
fermerait la boîte d'erreur ?
Merci encore ...
"michdenis" <michdenis@hotmail.com> a écrit dans le message de
news:uCqhXlxfEHA.3932@TK2MSFTNGP09.phx.gbl...
Re-Bonjour,
En supplément, modifie les 2 premières lignes de code par ceci :
If Not Intersect(Target, Columns(1)) Is Nothing Then
If Target.Rows.Count > 1 Then Exit Sub 'Celle-ci est nouvelle
Attention, à la disposition de tes images en Colonne B de ta feuille
BdD.
La procédure est basée sur la propriété TopLeftCell
d'un objet Range en l'occurrence dans le présent cas, des images. Si
ton
image n'est pas méticuleusement placée en colonne B
et qu'elle empiète sur la colonne A de quelques millimètres ... la
procédure ne s'exécutera pas adéquatement ...Donc avant de
copier la procédure assure-toi de l'emplacement de tes images !!!
Salutations!
"michdenis" <michdenis@hotmail.com> a écrit dans le message de
news:OxKjzbxfEHA.2764@TK2MSFTNGP11.phx.gbl...
Bonjour aife1,
Copie le code suivant dans le module code de ta feuille "Résultats" et
tu
pries !
'-------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rg As Range, Sh As Shape, R As Variant, S As Object
If Not Intersect(Target, Columns(1)) Is Nothing Then
With Worksheets("BdD")
R = Application.Match(Target, .Range("A:A"), 0)
If Not IsError(R) Then
Set Rg = .Range("A" & R)
Else
On Error GoTo 0
For Each Sh In Shapes
If Not Intersect(Sh.TopLeftCell, Target.Offset(, 1))
Is
Nothing Then
Sh.Delete
Exit Sub
End If
Next
End If
For Each Sh In .Shapes
If Not Intersect(Sh.TopLeftCell, Rg.Offset(, 1)) Is
Nothing Then
On Error Resume Next
Shapes("Picture " & Split(Sh.Name, " ")(1)).Delete
On Error GoTo 0
Sh.Copy
ActiveSheet.Paste
Set S = Selection
Set Rg = Target.Offset(, 1)
With Rg
Largeur = .Offset(, 1)(,
.Columns.Count).Left -
.Left
Hauteur = .Offset(.Rows.Count).Top -
.Item(1).Top
End With
With S
.Name = Sh.Name
.Left = Rg.Left
.Top = Rg.Top
'Largeur de l'image
S.Width = Largeur
'Hauteur de l'image
S.Height = Hauteur
'Est-ce que l'image doit se déplacer avec les
cellules
'voici les 3 constantes possibles
.Placement = xlFreeFloating 'or xlmove or
xlMoveAndSize
'Verrouillé ou pas
.Locked = True 'or False
End With
Rg.Offset(, 1).Select
End If
Next
End With
End If
Set Rg = Nothing: Set Sh = Nothing: Set S = Nothing
End Sub
'-------------------------------------
Salutations!
"aife1" <aife1@wanadoo.fr> a écrit dans le message de
news:%23UizZUrfEHA.3536@TK2MSFTNGP12.phx.gbl...
Bonjour à tous !!
Je sais que cette question a déjà été posée, mais les réponses ne
correspondent pas exactement à mes attentes.
Dans un classeur, j'ai deux feuilles : BdD et Résultats.
La feuille BdD comporte une base de données qui se présente de la
façon
suivante :
colonne A : nom du film
colonne B : image du film
colonne C : genre du film
colonne D : acteurs du film
...
Si dans la feuille Résultats je tape, dans la colonne A, le nom d'un
film
qui se trouve dans la base de données, je voudrais que l'image se
place
automatiquement en colonne B; le genre en colonne C, ...
Pour le texte, j'y arrive, c'est juste pour l'image.
A savoir que certains films ne comportent pas d'image et que dans la
colonne
A de la feuille Résultats, il peut y avoir un ou plusieurs films.
Merci d'avance pour vos conseils ...
Légère correction :
Dans cette section de la procédure : Prend bonne note du nouvel
emplacement de la ligne de code EXIT SUB...tu devrais
modifier la procédure émise lors de mon récent message .
If IsError(R) Then
On Error GoTo 0
If Shapes.Count = 0 Then Exit Sub
For Each Sh In Shapes
If Not Intersect(Sh.TopLeftCell, Target.Offset(, 1)) Is
Nothing Then
Sh.Delete
End If
Next
Exit Sub
Else
Set Rg = .Range("A" & R)
End If
Salutations!
"michdenis" a écrit dans le message de
news:%
Bonjour Aife1,
Essaie ceci :
'-----------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rg As Range, Sh As Shape, R As Variant, S As Object
If Not Intersect(Target, Columns(1)) Is Nothing Then
On Error Resume Next
With Worksheets("BdD")
If .Shapes.Count = 0 Then
For Each Sh In Shapes
Sh.Delete
Next
Exit Sub
End If
R = Application.Match(Target, .Range("A:A"), 0)
If IsError(R) Then
On Error GoTo 0
If Shapes.Count = 0 Then Exit Sub
For Each Sh In Shapes
If Not Intersect(Sh.TopLeftCell, Target.Offset(, 1)) Is
Nothing Then
Sh.Delete
Exit Sub
End If
Next
Else
Set Rg = .Range("A" & R)
End If
For Each Sh In .Shapes
If Not Intersect(Sh.TopLeftCell, Rg.Offset(, 1)) Is
Nothing Then
Shapes(Split(Sh.Name, " ")(0) & " " &
Target.Row).Delete
On Error GoTo 0
Sh.Copy
ActiveSheet.Paste
Set S = Selection
Set Rg = Target.Offset(, 1)
With Rg
Largeur = .Offset(, 1)(, .Columns.Count).Left -
.Left
Hauteur = .Offset(.Rows.Count).Top - .Item(1).Top
End With
With S
.Name = Split(Sh.Name, " ")(0) & " " & Target.Row
.Left = Rg.Left
.Top = Rg.Top
'Largeur de l'image
S.Width = Largeur
'Hauteur de l'image
S.Height = Hauteur
'Est-ce que l'image doit se déplacer avec les
cellules
'voici les 3 constantes possibles
.Placement = xlFreeFloating 'or xlmove or
xlMoveAndSize
'Verrouillé ou pas
.Locked = True 'or False
End With
Rg.Offset(, 1).Select
Else
Shapes("Picture " & Split(Sh.Name, " ")(1)).Delete
On Error GoTo 0
End If
Next
End With
End If
Set Rg = Nothing: Set Sh = Nothing: Set S = Nothing
End Sub
'-----------------------------------------
Salutations!
"aife1" a écrit dans le message de
news:
Excuse-moi, je me suis trompée dans la ligne d'erreur, il s'agit de :
If Not Intersect(Sh.TopLeftCell, Rg.Offset(, 1)) Is Nothing Then
Toutes mes excuses.
Amicalement
"aife1" a écrit dans le message de
news:O5r5%Bonjour Michdenis !
Tout d'abord, un très grand merci pour ton aide.
Ton code marche, mais il y une "erreur d'exécution 1004 : La méthode
'Intersect' de l'objet_Global a échoué" au niveau de la ligne suivante :If Not Intersect(Sh.TopLeftCell, Target.Offset(, 1))
Is
Nothing Then
A part cela, l'image se copie à merveille.
C'est ce que je comprend pas (je m'y connais pas trop en VBA), malgré
l'erreur, ça marche ! On ne pourrait pas mettre dans le code un truc qui
fermerait la boîte d'erreur ?
Merci encore ...
"michdenis" a écrit dans le message de
news:Re-Bonjour,
En supplément, modifie les 2 premières lignes de code par ceci :
If Not Intersect(Target, Columns(1)) Is Nothing Then
If Target.Rows.Count > 1 Then Exit Sub 'Celle-ci est nouvelle
Attention, à la disposition de tes images en Colonne B de ta feuille
BdD.La procédure est basée sur la propriété TopLeftCelld'un objet Range en l'occurrence dans le présent cas, des images. Si
ton
image n'est pas méticuleusement placée en colonne Bet qu'elle empiète sur la colonne A de quelques millimètres ... la
procédure ne s'exécutera pas adéquatement ...Donc avant decopier la procédure assure-toi de l'emplacement de tes images !!!
Salutations!
"michdenis" a écrit dans le message de
news:Bonjour aife1,
Copie le code suivant dans le module code de ta feuille "Résultats" et
tupries !
'-------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rg As Range, Sh As Shape, R As Variant, S As Object
If Not Intersect(Target, Columns(1)) Is Nothing Then
With Worksheets("BdD")
R = Application.Match(Target, .Range("A:A"), 0)
If Not IsError(R) Then
Set Rg = .Range("A" & R)
Else
On Error GoTo 0
For Each Sh In Shapes
If Not Intersect(Sh.TopLeftCell, Target.Offset(, 1))
Is
Nothing ThenSh.Delete
Exit Sub
End If
Next
End If
For Each Sh In .Shapes
If Not Intersect(Sh.TopLeftCell, Rg.Offset(, 1)) Is
Nothing ThenOn Error Resume Next
Shapes("Picture " & Split(Sh.Name, " ")(1)).Delete
On Error GoTo 0
Sh.Copy
ActiveSheet.Paste
Set S = Selection
Set Rg = Target.Offset(, 1)
With Rg
Largeur = .Offset(, 1)(,
.Columns.Count).Left -
.LeftHauteur = .Offset(.Rows.Count).Top -
.Item(1).TopEnd With
With S
.Name = Sh.Name
.Left = Rg.Left
.Top = Rg.Top
'Largeur de l'image
S.Width = Largeur
'Hauteur de l'image
S.Height = Hauteur
'Est-ce que l'image doit se déplacer avec les
cellules'voici les 3 constantes possibles
.Placement = xlFreeFloating 'or xlmove or
xlMoveAndSize'Verrouillé ou pas
.Locked = True 'or False
End With
Rg.Offset(, 1).Select
End If
Next
End With
End If
Set Rg = Nothing: Set Sh = Nothing: Set S = Nothing
End Sub
'-------------------------------------
Salutations!
"aife1" a écrit dans le message de
news:%Bonjour à tous !!
Je sais que cette question a déjà été posée, mais les réponses ne
correspondent pas exactement à mes attentes.
Dans un classeur, j'ai deux feuilles : BdD et Résultats.
La feuille BdD comporte une base de données qui se présente de la
façon
suivante :
colonne A : nom du film
colonne B : image du film
colonne C : genre du film
colonne D : acteurs du film
...
Si dans la feuille Résultats je tape, dans la colonne A, le nom d'un
filmqui se trouve dans la base de données, je voudrais que l'image se
place
automatiquement en colonne B; le genre en colonne C, ...
Pour le texte, j'y arrive, c'est juste pour l'image.
A savoir que certains films ne comportent pas d'image et que dans la
colonneA de la feuille Résultats, il peut y avoir un ou plusieurs films.
Merci d'avance pour vos conseils ...
