VBA image
c
Bonjour à tous,
J'ai crée un fichier qui va chercher automatiquement les données associées lorsque je choisis un produit depuis une liste (B9 du fichier joint).
Le problème c'est que j'aimerais également que mon code m'importe une image (qui se trouve dans une cellule de ma base) mais je n'y arrive pas.
Ci dessous mon code :
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Application.Intersect(Target, Range("B9")) Is Nothing Then Call données
End Sub
Sub données()
Dim Réf As String
Dim x As Variant, y As Variant
Dim WB As Worksheet, WFL As Worksheet
Set WFL = ThisWorkbook.Worksheets("Fiche logistique")
Set WB = ThisWorkbook.Worksheets("BASE")
Range("B12:B20").ClearContents
Range("B23:B30").ClearContents
Range("B33:B45").ClearContents
Réf = WFL.Cells(9, 2)
With WB
For x = 5 To .Range("A" & Rows.Count).End(xlUp).Row
If .Cells(x, 3) = Réf Then
y = 6
WFL.Cells(12, 2) = WB.Cells(x, y)
y = 7
WFL.Cells(13, 2) = WB.Cells(x, y)
y = 8
WFL.Cells(14, 2) = WB.Cells(x, y)
y = 9
WFL.Cells(15, 2) = WB.Cells(x, y)
y = 10
WFL.Cells(16, 2) = WB.Cells(x, y)
y = 11
WFL.Cells(17, 2) = WB.Cells(x, y)
y = 12
WFL.Cells(18, 2) = WB.Cells(x, y)
y = 13
WFL.Cells(19, 2) = WB.Cells(x, y)
y = 14
WFL.Cells(20, 2) = WB.Cells(x, y)
y = 15
WFL.Cells(23, 2) = WB.Cells(x, y)
y = 16
WFL.Cells(24, 2) = WB.Cells(x, y)
y = 17
WFL.Cells(25, 2) = WB.Cells(x, y)
y = 18
WFL.Cells(26, 2) = WB.Cells(x, y)
y = 19
WFL.Cells(27, 2) = WB.Cells(x, y)
y = 20
WFL.Cells(28, 2) = WB.Cells(x, y)
y = 21
WFL.Cells(29, 2) = WB.Cells(x, y)
y = 22
WFL.Cells(30, 2) = WB.Cells(x, y)
y = 23
WFL.Cells(33, 2) = WB.Cells(x, y)
y = 24
WFL.Cells(34, 2) = WB.Cells(x, y)
y = 25
WFL.Cells(35, 2) = WB.Cells(x, y)
y = 26
WFL.Cells(36, 2) = WB.Cells(x, y)
y = 27
WFL.Cells(37, 2) = WB.Cells(x, y)
y = 28
WFL.Cells(38, 2) = WB.Cells(x, y)
y = 29
WFL.Cells(39, 2) = WB.Cells(x, y)
y = 30
WFL.Cells(40, 2) = WB.Cells(x, y)
y = 31
WFL.Cells(41, 2) = WB.Cells(x, y)
y = 32
WFL.Cells(42, 2) = WB.Cells(x, y)
y = 33
WFL.Cells(43, 2) = WB.Cells(x, y)
y = 34
WFL.Cells(44, 2) = WB.Cells(x, y)
y = 35
WFL.Cells(45, 2) = WB.Cells(x, y)
y = 36
WFL.Cells(14, 4) = WB.Cells(x, y)
End If
Next
End With
End Suby=36 correspond à ma colonne où se trouvent les images et j'aimerais qu'elles se mettent en D14;
Ci-joint un extrait de mon fichier pour mieux comprendre (tout part de B9)
Merci !
Clem
bonjour,
une proposition
Sub données()
Dim Réf As String
Dim x As Variant, y As Variant
Dim WB As Worksheet, WFL As Worksheet
Set WFL = ThisWorkbook.Worksheets("Fiche logistique")
Set WB = ThisWorkbook.Worksheets("BASE")
WFL.Range("B12:B20").ClearContents
WFL.Range("B23:B30").ClearContents
WFL.Range("B33:B45").ClearContents
Réf = WFL.Cells(9, 2)
With WB
For x = 5 To .Range("A" & Rows.Count).End(xlUp).Row
If .Cells(x, 3) = Réf Then
y = 6
WFL.Cells(12, 2) = WB.Cells(x, y)
y = 7
WFL.Cells(13, 2) = WB.Cells(x, y)
y = 8
WFL.Cells(14, 2) = WB.Cells(x, y)
y = 9
WFL.Cells(15, 2) = WB.Cells(x, y)
y = 10
WFL.Cells(16, 2) = WB.Cells(x, y)
y = 11
WFL.Cells(17, 2) = WB.Cells(x, y)
y = 12
WFL.Cells(18, 2) = WB.Cells(x, y)
y = 13
WFL.Cells(19, 2) = WB.Cells(x, y)
y = 14
WFL.Cells(20, 2) = WB.Cells(x, y)
y = 15
WFL.Cells(23, 2) = WB.Cells(x, y)
y = 16
WFL.Cells(24, 2) = WB.Cells(x, y)
y = 17
WFL.Cells(25, 2) = WB.Cells(x, y)
y = 18
WFL.Cells(26, 2) = WB.Cells(x, y)
y = 19
WFL.Cells(27, 2) = WB.Cells(x, y)
y = 20
WFL.Cells(28, 2) = WB.Cells(x, y)
y = 21
WFL.Cells(29, 2) = WB.Cells(x, y)
y = 22
WFL.Cells(30, 2) = WB.Cells(x, y)
y = 23
WFL.Cells(33, 2) = WB.Cells(x, y)
y = 24
WFL.Cells(34, 2) = WB.Cells(x, y)
y = 25
WFL.Cells(35, 2) = WB.Cells(x, y)
y = 26
WFL.Cells(36, 2) = WB.Cells(x, y)
y = 27
WFL.Cells(37, 2) = WB.Cells(x, y)
y = 28
WFL.Cells(38, 2) = WB.Cells(x, y)
y = 29
WFL.Cells(39, 2) = WB.Cells(x, y)
y = 30
WFL.Cells(40, 2) = WB.Cells(x, y)
y = 31
WFL.Cells(41, 2) = WB.Cells(x, y)
y = 32
WFL.Cells(42, 2) = WB.Cells(x, y)
y = 33
WFL.Cells(43, 2) = WB.Cells(x, y)
y = 34
WFL.Cells(44, 2) = WB.Cells(x, y)
y = 35
WFL.Cells(45, 2) = WB.Cells(x, y)
y = 36
Set img = Nothing
For Each sh In WB.Shapes
If sh.TopLeftCell.Row = x And sh.TopLeftCell.Column = y Then
Set img = sh
Exit For
End If
Next
If Not img Is Nothing Then
img.Copy
WFL.Paste
Set sh = WFL.Shapes(1)
sh.Top = WFL.Cells(12, 4).Top
sh.Left = WFL.Cells(12, 4).Left
End If
End If
Next x
End With
End Subc
Merci h2so4 !
Petite question : le sh correspond à un objet ?
Par contre lorsqu'au début de mon code je mets :
Cells(12,4).ClearContents
L'image ne se supprime pas
Aurais-tu une solution ? (j'ai également essayé sh.Delete)
Clem
c
Pour supprimer les images, j'ai fait le code suivant (s'il y a une image en E13 et en E26) :
For Each sh In WFL.Shapes
If Not Intersect(Range("E13", "E26"), sh.TopLeftCell) Is Nothing Then sh.Delete
Next shClem
c
Salut !
J'ai continué mon code de la manière suivante mais les images ne se mettent pas dans la cellule que je souhaite.
ça fonctionne très bien lorsque je choisis le premier produit de ma BASE
(liste en B9 + C9 à sélectionner = REF)
Mais lorsque je choisis un autre produit les images se mettent n importe où...
Sais-tu quel est le problème ? j'aurai besoin d'aide ... (en PJ mon nouveau fichier)
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Application.Intersect(Target, Range("C9")) Is Nothing Then Call données
End Sub
Sub données()
Dim Réf As String
Dim x As Variant, y As Variant
Dim WB As Worksheet, WFL As Worksheet
Set WFL = ThisWorkbook.Worksheets("Fiche logistique")
Set WB = ThisWorkbook.Worksheets("BASE")
Range("B12:B20").ClearContents
Range("B23:B30").ClearContents
Range("B33:B45").ClearContents
Réf = WFL.Cells(9, 2) & WFL.Cells(9, 3)
With WB
For x = 5 To .Range("A" & Rows.Count).End(xlUp).Row
If .Cells(x, 5) & .Cells(x, 3) = Réf Then
y = 6
WFL.Cells(12, 2) = WB.Cells(x, y)
y = 7
WFL.Cells(13, 2) = WB.Cells(x, y)
y = 8
WFL.Cells(14, 2) = WB.Cells(x, y)
y = 9
WFL.Cells(15, 2) = WB.Cells(x, y)
y = 10
WFL.Cells(16, 2) = WB.Cells(x, y)
y = 11
WFL.Cells(17, 2) = WB.Cells(x, y)
y = 12
WFL.Cells(18, 2) = WB.Cells(x, y)
y = 13
WFL.Cells(19, 2) = WB.Cells(x, y)
y = 14
WFL.Cells(20, 2) = WB.Cells(x, y)
y = 15
WFL.Cells(23, 2) = WB.Cells(x, y)
y = 16
WFL.Cells(24, 2) = WB.Cells(x, y)
y = 17
WFL.Cells(25, 2) = WB.Cells(x, y)
y = 18
WFL.Cells(26, 2) = WB.Cells(x, y)
y = 19
WFL.Cells(27, 2) = WB.Cells(x, y)
y = 20
WFL.Cells(28, 2) = WB.Cells(x, y)
y = 21
WFL.Cells(29, 2) = WB.Cells(x, y)
y = 22
WFL.Cells(30, 2) = WB.Cells(x, y)
y = 23
WFL.Cells(33, 2) = WB.Cells(x, y)
y = 24
WFL.Cells(34, 2) = WB.Cells(x, y)
y = 25
WFL.Cells(35, 2) = WB.Cells(x, y)
y = 26
WFL.Cells(36, 2) = WB.Cells(x, y)
y = 27
WFL.Cells(37, 2) = WB.Cells(x, y)
y = 28
WFL.Cells(38, 2) = WB.Cells(x, y)
y = 29
WFL.Cells(39, 2) = WB.Cells(x, y)
y = 30
WFL.Cells(40, 2) = WB.Cells(x, y)
y = 31
WFL.Cells(41, 2) = WB.Cells(x, y)
y = 32
WFL.Cells(42, 2) = WB.Cells(x, y)
y = 33
WFL.Cells(43, 2) = WB.Cells(x, y)
y = 34
WFL.Cells(44, 2) = WB.Cells(x, y)
y = 35
WFL.Cells(45, 2) = WB.Cells(x, y)
y = 36
Set img = Nothing
For Each sh In WB.Shapes
If sh.TopLeftCell.Row = x And sh.TopLeftCell.Column = y Then
Set img = sh
Exit For
End If
Next sh
If Not img Is Nothing Then
img.Copy
WFL.Paste
Set sh = WFL.Shapes(1)
sh.Top = WFL.Cells(13, 5).Top
sh.Left = WFL.Cells(13, 5).Left
End If
y = 37
Set img = Nothing
For Each sh In WB.Shapes
If sh.TopLeftCell.Row = x And sh.TopLeftCell.Column = y Then
Set img = sh
Exit For
End If
Next
If Not img Is Nothing Then
img.Copy
WFL.Paste
Set sh = WFL.Shapes(2)
sh.Top = WFL.Cells(26, 5).Top
sh.Left = WFL.Cells(26, 5).Left
End If
y = 38
Set img = Nothing
For Each sh In WB.Shapes
If sh.TopLeftCell.Row = x And sh.TopLeftCell.Column = y Then
Set img = sh
Exit For
End If
Next
If Not img Is Nothing Then
img.Copy
WFL.Paste
Set sh = WFL.Shapes(3)
sh.Top = WFL.Cells(37, 5).Top
sh.Left = WFL.Cells(37, 5).Left
End If
End If
Next
End With
End Subc
Merci beaucoup de ton aide !
Clem