Vba copie d'image

**cleiiim** · 10/04/2019, 09h37

Bonjour !

J'ai fait un code (avec de l'aide) de la manière suivante mais les images ne se mettent pas dans la cellule que je souhaite.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
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 Sub

Je vous explique mon fichier, je choisis en B9 une marque et en C9 un produit, lorsque que mon code cherche dans ma feuille BASE, il vient m'importer les valeurs trouvées.

Pour les images, ç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ù...

Auriez-vous une idée ? j'aurai besoin d'aide ... (en PJ mon fichier)

Merci,
Clem

**mercatog** · 10/04/2019, 11h25

Bonjour

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
Private Sub Worksheet_Change(ByVal Target As Range)
 
If Target.Address = "$C$9" Then
    Application.EnableEvents = False
    Donnees
    Application.EnableEvents = True
End If
End Sub
 
Sub Donnees()
Dim i As Long, Lig As Long
Dim Wb As Worksheet
Dim Ref As String
Dim Shp As Shape
 
Application.ScreenUpdating = False
Range("B12:B20").ClearContents
Range("B23:B30").ClearContents
Range("B33:B45").ClearContents
For Each Shp In ActiveSheet.Shapes
    Shp.Delete
Next Shp
 
Ref = Cells(9, 2) & Cells(9, 3)
 
Set Wb = ThisWorkbook.Worksheets("BASE")
With Wb
    For i = 5 To .Range("A" & Rows.Count).End(xlUp).Row
        If .Cells(i, 5) & .Cells(i, 3) = Ref Then
            Cells(12, 2).Resize(9).Value = Application.Transpose(Wb.Cells(i, 6).Resize(, 9).Value)
            Cells(23, 2).Resize(8).Value = Application.Transpose(Wb.Cells(i, 15).Resize(, 8).Value)
            Cells(33, 2).Resize(13).Value = Application.Transpose(Wb.Cells(i, 23).Resize(, 13).Value)
            Exit For
        End If
    Next i
    For Each Shp In Wb.Shapes
        If Shp.TopLeftCell.Row = i Then
            Select Case Shp.TopLeftCell.Column
                Case 36: Lig = 13
                Case 37: Lig = 25
                Case 38: Lig = 35
            End Select
            If Lig > 0 Then
                Shp.Copy
                Cells(Lig, 5).PasteSpecial
                Lig = 0
            End If
        End If
    Next Shp
End With
Set Wb = Nothing
Range("C9").Select
End Sub

**cleiiim** · 10/04/2019, 13h22

Merci beaucoup !

Je ne connaissais pas cette "manière" d'écrire, c'est intéressant d'apprendre des choses

Clem

**cleiiim** · 10/04/2019, 13h58

Re,

je viens de me rendre compte que lorsque je choisis mon produit (en C9) ma macro fonctionne parfaitement mais ensuite ma liste n'est plus disponible (pourtant elle est bien activée dans ma validation de données mais plus de liste ans la cellule ...

Clem

**cleiiim** · 10/04/2019, 14h09

ça n'est pas à cause de cette ligne de code par hasard ?

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
For Each Shp In ActiveSheet.Shapes
    Shp.Delete
Next Shp

**mercatog** · 10/04/2019, 15h52

En effet

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
For Each Shp In ActiveSheet.Shapes
    If Shp.Type <> 8 Then Shp.delete
Next Shp

Ou if shp.type=6 then shp.delete

Vba copie d'image

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager