Afficher des images

**ExcelTastic** · 28/04/2025, 16h30

Salut Promethee

Envoyé par Promethee25

Bonjour,
Il existe une technique intéressante pour récupérer l'image par formule (désolé c'est en anglais):
https://trumpexcel.com/picture-lookup/
Je l'utilise avec succès dans un fichier que j'ai créé il y a deux ans.

Sauf qu'en l'occurrence, il ne s'agit pas de récupérer une image, mais une suite d'images les unes en dessous des autres

**cobra38** · 02/05/2025, 15h00

Envoyé par Qwazerty

Voila le code modifié

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
Option Explicit
 
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim S As Variant
Dim FindRg As Range
Dim memoSU As Boolean
 
    'Initialisation
    'En cas d'erreur, on passe à la ligne suivante sans déclencher de message
    On Error Resume Next
    'On pointe les cellules présente dans la selection et dans la 1ère colonne du tableau
    Set FindRg = Intersect(Target, Sh.ListObjects(1).ListColumns(1).Range)
 
    'En cas d'erreur, on bascule directemnt à la fin
    On Error GoTo fin
 
    'On mémorise la position de screenupdating
    memoSU = Application.ScreenUpdating
 
    'On ne rafraichi plus l'écran
    Application.ScreenUpdating = False
 
    'On vérifie qu'il ne s'agit pas de la feuille base de données (à adapter pour cibler que les feuilles qui doivent faire l'objet d'un import d'image)
    'On regarde aussi qu'il n'y a qu'une cellule modifiée et qu'elle se trouve dans la 1ère colonne de la feuille
    If Sh.CodeName <> "F_Base" And (Not FindRg Is Nothing) And Target.Count = 1 Then
        '-- suppression
        'On boucle sur toute les images présentes
        For Each S In Sh.Shapes
            'If S.Type = 13 Or S.Type = 9 Then
                'On regarde si l'adresse de la cellule qui contient cette image correspond à la cellule à droite de Target, si c'est le cas, on la supprime
                If S.TopLeftCell.Address = Target.Offset(0, 1).Address Then
                    'On supprime l'image
                    S.Delete
                    'Si target est vide, on supprime la ligne
                    If Target.Value = "" Then
                        'On faire la correspondance en terme de ligne dans le tableau structuré
                        With Sh.ListObjects(1)
                            'Avant de supprimer la ligne, on s'assure qu'il ne s'agit pas de la dernière ligne vide du tableau!
                            'On prend le numero de ligne contenant target et on lui soustrait le numero de ligne où se trouve l'entête du tableau
                            'On pointe la ligne du tableau structuré correspondante
                            With .ListRows(Target.Row - .HeaderRowRange.Row)
                                'On vérifie qu'il ne s'agit pas de la dernière ligne du tableau
                                If .Index < Sh.ListObjects(1).ListRows.Count Then
                                    'On supprime la ligne
                                    .Delete
                                    'On quite la boucle For (Target n'existe plus)
                                    GoTo TargetKilled
                                End If
                            End With
                        End With
                    End If
                End If
            'End If
        Next
 
        'Si Target est vide, on ne remet pas d'image
        If Target <> "" Then
            'On recheche la correspondence dans le tableau Base de donnée
            Set FindRg = F_Base.ListObjects("Tab_Base").ListColumns(1).Range.Find(Target, LookAt:=xlWhole)
            'On place une copie de l'image Vide
            F_Base.Shapes("Img_Vide").Copy
            Target.Offset(0, 1).PasteSpecial
 
            'On s'assure qu'une correspondence à été trouvée, sinon on laisse vide
            If Not FindRg Is Nothing Then
                'On place en formule, le lien vers la cellule dont on veut capturer l'apparence
                Selection.Formula = FindRg.Offset(0, 2).Address(External:=True)
            End If
 
            'On laisse du temps à Windows/Excel de faire le boulot
            DoEvents
            'On rétablie la dimenssion de l'image
            With Selection.ShapeRange
                .ScaleHeight 1, msoTrue
                .ScaleWidth 1, msoTrue
                'On affine la mise en place
                .Left = Target.Offset(0, 1).Left + 7
                .Top = Target.Offset(0, 1).Top + 5
                'On adapte la taille de la ligne
                Target.RowHeight = .Height + 10
            End With
 
        End If
 
TargetKilled:
        'On regarde si la dernière ligne du tableau à une cellule vide, sinon, on ajoute une ligne pour bénéficier de la liste déroulante la prochaine fois
        With Sh.ListObjects(1)
            'On s'assure qu'il existe du contenu dans le tableau
            If .ListRows.Count > 0 Then
                'On vérifie si la 1ère cellule de la dernière ligne contient du text
                If .ListRows(.ListRows.Count).Range(1).Value <> "" Then
                    'On ajoute une ligne vide
                    .ListRows.Add
                End If
            Else
                'On ajoute une ligne pour que le tableau est au moins une ligne vide
                .ListRows.Add
            End If
        End With
    End If
fin:
    'On rétabli la rafraichissement d'écran*
    Application.ScreenUpdating = memoSU
 
    'On affiche l'erreur si présente
    If Err.Number <> 0 Then
        MsgBox "L'erreur suivante est apparue" & vbCrLf & Err.Number & vbCrLf & Err.Description, vbCritical, "Erreur"
        Err.Clear
        Resume
    End If
End Sub

Si tu gardes l'optique d'utiliser ce code, il peut y avoir deux améliorations

Une mineure, qui serait de gérer application.enabledevents pour empêcher de réexécuter le code au moment de la suppression d'une ligne (ça appelle OnChange)
Une majeure, en supprimant le test Target.count = 1 et en gérant ensuite une boucle sur les cellules sélectionnées (en faisant un intersect en 1er lieu pour limiter aux cellules de la colonne article). En faisant ça, tu pourrais supprimer plusieurs article en une fois et/ou ajouter plusieurs composant d'un coup en copiant des valeur en bas de la liste.

++
Qwaz

Bonjour Qwazerty

Pardon pour le retard , j'ai essayé le nouveau programme permettant une suppression de ligne conjuguée avec une suppression d'image
malheureusement je me heurte toujours au même message qui m'oblige à sortir de Excel avec CRTL-ALT-DEL
à savoir :

Ton aide me serait précieuse

Cordialement
pascal

**Qwazerty** · 02/05/2025, 18h22

Salut

Essai en supprimant la (non) gestion d'erreur pour voir qu'elle ligne plante.

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
 
Option Explicit
 
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim S As Variant
Dim FindRg As Range
Dim memoSU As Boolean
 
    'Initialisation
    'En cas d'erreur, on passe à la ligne suivante sans déclencher de message
    'On Error Resume Next
    'On pointe les cellules présente dans la selection et dans la 1ère colonne du tableau
    Set FindRg = Intersect(Target, Sh.ListObjects(1).ListColumns(1).Range)
 
    'En cas d'erreur, on bascule directemnt à la fin
    'On Error GoTo fin
 
    'On mémorise la position de screenupdating
    memoSU = Application.ScreenUpdating
 
    'On ne rafraichi plus l'écran
    Application.ScreenUpdating = False
 
    'On vérifie qu'il ne s'agit pas de la feuille base de données (à adapter pour cibler que les feuilles qui doivent faire l'objet d'un import d'image)
    'On regarde aussi qu'il n'y a qu'une cellule modifiée et qu'elle se trouve dans la 1ère colonne de la feuille
    If Sh.CodeName <> "F_Base" And (Not FindRg Is Nothing) And Target.Count = 1 Then
        '-- suppression
        'On boucle sur toute les images présentes
        For Each S In Sh.Shapes
            'If S.Type = 13 Or S.Type = 9 Then
                'On regarde si l'adresse de la cellule qui contient cette image correspond à la cellule à droite de Target, si c'est le cas, on la supprime
                If S.TopLeftCell.Address = Target.Offset(0, 1).Address Then
                    'On supprime l'image
                    S.Delete
                    'Si target est vide, on supprime la ligne
                    If Target.Value = "" Then
                        'On faire la correspondance en terme de ligne dans le tableau structuré
                        With Sh.ListObjects(1)
                            'Avant de supprimer la ligne, on s'assure qu'il ne s'agit pas de la dernière ligne vide du tableau!
                            'On prend le numero de ligne contenant target et on lui soustrait le numero de ligne où se trouve l'entête du tableau
                            'On pointe la ligne du tableau structuré correspondante
                            With .ListRows(Target.Row - .HeaderRowRange.Row)
                                'On vérifie qu'il ne s'agit pas de la dernière ligne du tableau
                                If .Index < Sh.ListObjects(1).ListRows.Count Then
                                    'On supprime la ligne
                                    .Delete
                                    'On quite la boucle For (Target n'existe plus)
                                    GoTo TargetKilled
                                End If
                            End With
                        End With
                    End If
                End If
            'End If
        Next
 
        'Si Target est vide, on ne remet pas d'image
        If Target <> "" Then
            'On recheche la correspondence dans le tableau Base de donnée
            Set FindRg = F_Base.ListObjects("Tab_Base").ListColumns(1).Range.Find(Target, LookAt:=xlWhole)
            'On place une copie de l'image Vide
            F_Base.Shapes("Img_Vide").Copy
            Target.Offset(0, 1).PasteSpecial
 
            'On s'assure qu'une correspondence à été trouvée, sinon on laisse vide
            If Not FindRg Is Nothing Then
                'On place en formule, le lien vers la cellule dont on veut capturer l'apparence
                Selection.Formula = FindRg.Offset(0, 2).Address(External:=True)
            End If
 
            'On laisse du temps à Windows/Excel de faire le boulot
            DoEvents
            'On rétablie la dimenssion de l'image
            With Selection.ShapeRange
                .ScaleHeight 1, msoTrue
                .ScaleWidth 1, msoTrue
                'On affine la mise en place
                .Left = Target.Offset(0, 1).Left + 7
                .Top = Target.Offset(0, 1).Top + 5
                'On adapte la taille de la ligne
                Target.RowHeight = .Height + 10
            End With
 
        End If
 
TargetKilled:
        'On regarde si la dernière ligne du tableau à une cellule vide, sinon, on ajoute une ligne pour bénéficier de la liste déroulante la prochaine fois
        With Sh.ListObjects(1)
            'On s'assure qu'il existe du contenu dans le tableau
            If .ListRows.Count > 0 Then
                'On vérifie si la 1ère cellule de la dernière ligne contient du text
                If .ListRows(.ListRows.Count).Range(1).Value <> "" Then
                    'On ajoute une ligne vide
                    .ListRows.Add
                End If
            Else
                'On ajoute une ligne pour que le tableau est au moins une ligne vide
                .ListRows.Add
            End If
        End With
    End If
fin:
    'On rétabli la rafraichissement d'écran*
    Application.ScreenUpdating = memoSU
 
    'On affiche l'erreur si présente
    If Err.Number <> 0 Then
        MsgBox "L'erreur suivante est apparue" & vbCrLf & Err.Number & vbCrLf & Err.Description, vbCritical, "Erreur"
        Err.Clear
        Resume
    End If
End Sub

Si ça refait pareil et que ça ne te permet pas de voir quelle ligne bloque, fais la manip suivante:

Clic sur la ligne de code

Code :

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

1
2
 
Set FindRg = Intersect(Target, Sh.ListObjects(1).ListColumns(1).Range)

Ensuite appuie sur la touche F9 de ton clavier. Si tout se passe bien, un gros point rouge devrait apparaitre au début de la ligne de code. Pour info, ceci est un point d'arrêt. Ca signifie qu'avant que cette ligne de code soit exécutée, l’interpréteur va s'arrêter et attendre une action de ta part.
Modifie une cellule de ta feuille (attention à ne pas taper trop vite, place juste une lettre dans la celllule, sinon tu vas basculer automatiquement dans l’éditeur VBA et tu risque d'écraser du code)
Si tout se passe bien, l'éditeur à fait surface et la ligne au point rouge est surligné en jaune.
Appuie sur F8, la zone jaune va se déplacer. A chaque déplacement, le code qu'elle quitte est exécuté.
Renouvelle l'utilisation de F8 jusqu'au plantage d'Excel ou au message d'erreur.
Relève la ligne et indique là ici. Pour info, quand tu est en mode débogage (avec une ligne surligné en jaune), tu peux survoler le code de la procédure pour avoir des informations sur le contenu des variables. Il est aussi possible de mettre des espions pour suivre les modifications de contenu (y'a des tuto sur le sujet)

++
Qwaz

**cobra38** · 02/05/2025, 20h51

la ligne qui bloque c'est celle-ci ....

**Qwazerty** · 02/05/2025, 21h37

Alors il y avait 2 coquilles dans mon code, qui se cumulaient...

J'avais laissé une ligne de code que j'avais ajouté pour rechercher la ligne qui provoquait une erreur et j'ai oublié de la désactiver... C'est le mot resume en bas. Quand le code plantait, il allait directement à l'étiquette fin, puis rentré dans le if, on affiche un message avec les infos sur l'erreur et on nettoie l'erreur... (jusque là normal). Resume renvoie l’interpréter là où l'erreur a eu lieu... la ligne replante... repart à l’étiquette Fin...
Seule solution pour quitter cette boucle si ça t'arrive encore, c'est d'appuyer plusieurs fois de suite sur la touche échappe. 1er coup ça ferme la box avec le message, second appuie, ça interrompt l'exécution du code
le petit bouton qui actionne la liste déroulante et inclus dans la boucle des shapes.. sauf qu'il ne fait pas parti des images à traiter... d'ou le
Code : Sélectionner tout - Visualiser dans une fenêtre à part
```
If S.Type = 13 Or S.Type = 9 Then
```
qu'avait mis riton00

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
Option Explicit
 
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim S As Variant
Dim FindRg As Range
Dim memoSU As Boolean
 
    'Initialisation
    'En cas d'erreur, on passe à la ligne suivante sans déclencher de message
    On Error Resume Next
    'On pointe les cellules présente dans la selection et dans la 1ère colonne du tableau
    Set FindRg = Intersect(Target, Sh.ListObjects(1).ListColumns(1).Range)
 
    'En cas d'erreur, on bascule directemnt à la fin
    On Error GoTo fin
 
    'On mémorise la position de screenupdating
    memoSU = Application.ScreenUpdating
 
    'On ne rafraichi plus l'écran
    Application.ScreenUpdating = False
 
    'On vérifie qu'il ne s'agit pas de la feuille base de données (à adapter pour cibler que les feuilles qui doivent faire l'objet d'un import d'image)
    'On regarde aussi qu'il n'y a qu'une cellule modifiée et qu'elle se trouve dans la 1ère colonne de la feuille
    If Sh.CodeName <> "F_Base" And (Not FindRg Is Nothing) And Target.Count = 1 Then
        '-- suppression
        'On boucle sur toute les images présentes
        For Each S In Sh.Shapes
            If S.Type = 13 Or S.Type = 9 Then
                'On regarde si l'adresse de la cellule qui contient cette image correspond à la cellule à droite de Target, si c'est le cas, on la supprime
                If S.TopLeftCell.Address = Target.Offset(0, 1).Address Then
                    'On supprime l'image
                    S.Delete
                    'Si target est vide, on supprime la ligne
                    If Target.Value = "" Then
                        'On faire la correspondance en terme de ligne dans le tableau structuré
                        With Sh.ListObjects(1)
                            'Avant de supprimer la ligne, on s'assure qu'il ne s'agit pas de la dernière ligne vide du tableau!
                            'On prend le numero de ligne contenant target et on lui soustrait le numero de ligne où se trouve l'entête du tableau
                            'On pointe la ligne du tableau structuré correspondante
                            With .ListRows(Target.Row - .HeaderRowRange.Row)
                                'On vérifie qu'il ne s'agit pas de la dernière ligne du tableau
                                If .Index < Sh.ListObjects(1).ListRows.Count Then
                                    'On supprime la ligne
                                    .Delete
                                    'On quite la boucle For (Target n'existe plus)
                                    GoTo TargetKilled
                                End If
                            End With
                        End With
                    End If
                End If
            End If
        Next
 
        'Si Target est vide, on ne remet pas d'image
        If Target <> "" Then
            'On recheche la correspondence dans le tableau Base de donnée
            Set FindRg = F_Base.ListObjects("Tab_Base").ListColumns(1).Range.Find(Target, LookAt:=xlWhole)
            'On place une copie de l'image Vide
            F_Base.Shapes("Img_Vide").Copy
            Target.Offset(0, 1).PasteSpecial
 
            'On s'assure qu'une correspondence à été trouvée, sinon on laisse vide
            If Not FindRg Is Nothing Then
                'On place en formule, le lien vers la cellule dont on veut capturer l'apparence
                Selection.Formula = FindRg.Offset(0, 2).Address(External:=True)
            End If
 
            'On laisse du temps à Windows/Excel de faire le boulot
            DoEvents
            'On rétablie la dimenssion de l'image
            With Selection.ShapeRange
                .ScaleHeight 1, msoTrue
                .ScaleWidth 1, msoTrue
                'On affine la mise en place
                .Left = Target.Offset(0, 1).Left + 7
                .Top = Target.Offset(0, 1).Top + 5
                'On adapte la taille de la ligne
                Target.RowHeight = .Height + 10
            End With
 
        End If
 
TargetKilled:
        'On regarde si la dernière ligne du tableau à une cellule vide, sinon, on ajoute une ligne pour bénéficier de la liste déroulante la prochaine fois
        With Sh.ListObjects(1)
            'On s'assure qu'il existe du contenu dans le tableau
            If .ListRows.Count > 0 Then
                'On vérifie si la 1ère cellule de la dernière ligne contient du text
                If .ListRows(.ListRows.Count).Range(1).Value <> "" Then
                    'On ajoute une ligne vide
                    .ListRows.Add
                End If
            Else
                'On ajoute une ligne pour que le tableau est au moins une ligne vide
                .ListRows.Add
            End If
        End With
    End If
fin:
    'On rétabli la rafraichissement d'écran*
    Application.ScreenUpdating = memoSU
 
    'On affiche l'erreur si présente
    If Err.Number <> 0 Then
        MsgBox "L'erreur suivante est apparue" & vbCrLf & Err.Number & vbCrLf & Err.Description, vbCritical, "Erreur"
        Err.Clear
        'Resume
    End If
End Sub

++
Qwaz

**cobra38** · 04/05/2025, 13h57

Salut Qwazerty

merci encore de prendre du temps pour mon petit problème

j'ai essayé le code que tu m'as envoyé dernièrement et voici ce que j'ai observé :

1) si la suppression est la dernière ligne de la liste d'article, çà fonctionne comme avant càd dire que lorsque je supprime la ligne, je suis obligé de supprimer manuellement l'image par la suite ( mais ce n'est pas gênant en soi )
2) si la suppression n'est pas la dernière de la liste d'article, çà fonctionne correctement càd que la ligne est entièrement supprimée y compris l'image puis la ligne et l'image sont bien remplacées par celles du dessous

Bien cordialement
pascal

Update : après vérification , l'image pour le point N°1 n'est pas supprimée mais cachée
en fait, l'image reste toujours présente dans les 2 cas de suppression

**Qwazerty** · 04/05/2025, 14h11

Salut

Envoyé par cobra38

1) si la suppression est la dernière ligne de la liste d'article, çà fonctionne comme avant càd dire que lorsque je supprime la ligne, je suis obligé de supprimer manuellement l'image par la suite ( mais ce n'est pas gênant en soi )

La dernière ligne doit contenir 2 cellules vides pour permettre l'utilisation de la liste déroulante pour ajouter un nouvel article. Cette ligne ne doit (et ne peut) pas être supprimé par le code, si tu essais de supprimer le contenu de la 1er cellule de la dernière ligne ( qui est déjà vide), il ne devrait rien se passer.

Pour être sûr qu'on utilise le même fichier, je remet une version "propre"

++
Qwaz

**cobra38** · 04/05/2025, 14h29

Re...

J'ai essayé le fichier Test et j'arrive à la même conclusion
je pense que je suis à l'origine du problème càd que je manipule mal le fichier
voilà le scénario :
1) j'ajoute un article dans le journal des entrées-sorties (feuil3) => l'article et l'image s'affichent normalement et te remercient encore

et une nouvelle ligne s'ajoute au fichier
2) lorsque je supprime cette avant-dernière ligne avec image, alors la ligne s'efface mais l'image reste et l'effacement est fait de façon manuelle

j'ai testé ceci sur le fichier Test que tu m'as envoyé , cela fait la même chose chez toi ?

pascal

**Qwazerty** · 04/05/2025, 14h40

Non, je n'ai pas un tel phénomène

On est d'accord que quand tu dis "lorsque je supprime cette avant-dernière ligne avec image", tu te contentes d'effacer le contenu de la 1ère cellule de la ligne, celle qui contient le nom de l'article?

**cobra38** · 04/05/2025, 15h02

Re...

On est d'accord que quand tu dis "lorsque je supprime cette avant-dernière ligne avec image", tu te contentes d'effacer le contenu de la 1ère cellule de la ligne, celle qui contient le nom de l'article?

ben non en fait ....
Je me disais que je faisais n'importe quoi (

) en fait je supprimais la ligne complète (?)
là maintenant çà marche beaucoup mieux ....
Mille excuses pour le dérangement

pascal

**Qwazerty** · 04/05/2025, 15h11

Pas de soucis.

tiens voila un code qui autorise de "supprimer" (effacer le contenu) ou d'ajouter plusieurs lignes en une fois.

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
Option Explicit
 
'### Il serait préférable de mettre cette petite partie de code qui suit dans un module (si tu le fais, replace les Private par Public dans la suite
    'C'est normal qu'une des lignes apparaisse en rouge en fonction de ta version Excel 64 ou 32bit
    #If VBA7 And Win64 Then
        Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
    #Else
        Private Declare Sub Sleep Lib "kernel32" Alias "Sleep" (ByVal dwMilliseconds As Long)
    #End If
'### Fin
 
 
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim S As Variant
Dim FindRg As Range, ArticleRg As Range
Dim memoSU As Boolean, memoEE As Boolean
Dim iCell As Integer
 
    'Initialisation
    'En cas d'erreur, on passe à la ligne suivante sans déclencher de message
    On Error Resume Next
    'On pointe les cellules présentes dans la selection et dans la 1ère colonne du tableau
    Set FindRg = Intersect(Target, Sh.ListObjects(1).ListColumns(1).Range)
 
    'En cas d'erreur, on bascule directemnt à la fin
    On Error GoTo fin
 
    'On mémorise la position de screenupdating
    memoSU = Application.ScreenUpdating
    memoEE = Application.EnableEvents
 
    'On ne rafraichi plus l'écran
    Application.ScreenUpdating = False
 
    'On vérifie qu'il ne s'agit pas de la feuille base de données (à adapter pour cibler que les feuilles qui doivent faire l'objet d'un import d'image)
    'On regarde aussi qu'il n'y a qu'une cellule modifiée et qu'elle se trouve dans la 1ère colonne de la feuille
    If Sh.CodeName <> "F_Base" And (Not FindRg Is Nothing) Then  'And Target.Count = 1
        'On boucle sur les différentes cellules de target qui sont incluses dans la 1er colonne du tableau
        'On part du bas du tableau pour éviter les problème lors de la suppression
        For iCell = FindRg.Count To 1 Step -1
 
            'On boucle sur toute les images présentes
            For Each S In Sh.Shapes
                If S.Type = 13 Or S.Type = 9 Then
                    'On regarde si l'adresse de la cellule qui contient cette image correspond à la cellule à droite de findrg(icell), si c'est le cas, on la supprime
                    If S.TopLeftCell.Address = FindRg(iCell).Offset(0, 1).Address Then
                        'On supprime l'image
                        S.Delete
                        'Si findrg(icell) est vide, on supprime la ligne
                        If FindRg(iCell).Value = "" Then
                            'On faire la correspondance en terme de ligne dans le tableau structuré
                            With Sh.ListObjects(1)
                                'Avant de supprimer la ligne, on s'assure qu'il ne s'agit pas de la dernière ligne vide du tableau!
                                'On prend le numero de ligne contenant findrg(icell) et on lui soustrait le numero de ligne où se trouve l'entête du tableau
                                'On pointe la ligne du tableau structuré correspondante
                                With .ListRows(FindRg(iCell).Row - .HeaderRowRange.Row)
                                    'On vérifie qu'il ne s'agit pas de la dernière ligne du tableau
                                    If .Index < Sh.ListObjects(1).ListRows.Count Then
                                        'On supprime la ligne
                                        .Delete
                                        'On quite la boucle For (findrg(icell) n'existe plus)
                                        GoTo TargetKilled
                                    End If
                                End With
                            End With
                        End If
                    End If
                End If
            Next
 
            'Si findrg(icell) est vide, on ne remet pas d'image
            If FindRg(iCell) <> "" Then
                'On recheche la correspondence dans le tableau Base de donnée
                Set ArticleRg = F_Base.ListObjects("Tab_Base").ListColumns(1).Range.Find(FindRg(iCell), LookAt:=xlWhole)
                'On place une copie de l'image Vide
                F_Base.Shapes("Img_Vide").Copy
                FindRg(iCell).Offset(0, 1).PasteSpecial
 
                'On s'assure qu'une correspondence à été trouvée, sinon on laisse vide
                If Not ArticleRg Is Nothing Then
                    'On place en formule, le lien vers la cellule dont on veut capturer l'apparence
                    Selection.Formula = ArticleRg.Offset(0, 2).Address(External:=True)
                End If
 
                'On laisse du temps à Windows/Excel de faire le boulot
                DoEvents
                Sleep 100
                DoEvents
                'On rétablie la dimenssion de l'image
                With Selection.ShapeRange
                    .ScaleHeight 1, msoTrue
                    .ScaleWidth 1, msoTrue
                    'On affine la mise en place
                    .Left = FindRg(iCell).Offset(0, 1).Left + 7
                    .Top = FindRg(iCell).Offset(0, 1).Top + 5
                    'On adapte la taille de la ligne
                    FindRg(iCell).RowHeight = .Height + 10
                End With
 
            End If
 
TargetKilled:
        Next
 
        'On regarde si la dernière ligne du tableau à une cellule vide, sinon, on ajoute une ligne pour bénéficier de la liste déroulante la prochaine fois
        With Sh.ListObjects(1)
            'On s'assure qu'il existe du contenu dans le tableau
            If .ListRows.Count > 0 Then
                'On vérifie si la 1ère cellule de la dernière ligne contient du text
                If .ListRows(.ListRows.Count).Range(1).Value <> "" Then
                    'On ajoute une ligne vide
                    Application.EnableEvents = False
                    .ListRows.Add
                End If
            Else
                'On ajoute une ligne pour que le tableau est au moins une ligne vide
                .ListRows.Add
            End If
        End With
    End If
fin:
    'On rétabli la rafraichissement d'écran*
    Application.ScreenUpdating = memoSU
    Application.EnableEvents = memoEE
 
    'On affiche l'erreur si présente
    If Err.Number <> 0 Then
        MsgBox "L'erreur suivante est apparue" & vbCrLf & Err.Number & vbCrLf & Err.Description, vbCritical, "Erreur"
        Err.Clear
        'Resume
    End If
End Sub

Le code est plutôt lent, il faudrait peut-être récupérer la liste des images et des lignes à supprimer et tout faire d'un coup.

J'ai ajouté un petit temps d'attente sleep, j'ai remarqué que lors de plusieurs ajouts successif ça plantait parfois. Ca arrive souvent avec les code qui colle des objets (image par exemple), j'ai déjà rencontré ça dans mes fichiers.
La déclaration de la function Sleep peut être placée dans un Module (il faut replacer des Private par Public si tu le fais). L'avantage, c'est que si tu as d'autre module de code, sleep sera accessible par tous. (Ici Sleep n'est utilisable dans dans le code de thisWorkBook)

++
Qwaz

**cobra38** · 04/05/2025, 15h36

Mercis Mille fois
çà a l'air de fonctionner
j'ai mis dans un module les déclarations d'entête en ayant soin de changer Private par Public étant donner qu'ils ne sont plus dans la partie initiale

j'aurais, si tu le permets, une dernière demande
j'ai vu que mon fichier avec images prenait des proportions gargantuesques avec pourtant peu d'images et la lenteur de traitement qui va avec ....
aurais-tu stp quelques suggestions à me proposer pour que je puisse accélérer le traitement ?

**Qwazerty** · 04/05/2025, 16h31

C'est pour ça que j’évoquais le fait qu'il serait mieux d'externaliser ta base.

Déjà il faut que tes images soit dimensionnées au plus juste (en terme de taille mais aussi de résolution) pour que leur taille soit réduite le plus possible.

Excel peut y aider mais il vaudrait mieux le faire en amont je pense, pour mieux maitriser la qualité des images, ni trop, ni trop peu. Dans le ruban image qui apparait à la sélection d'une image, dans le groupe Ajuster, tu as un bouton "compression des images", avec des options de résolution, de suppression des zones cropées, ... ça peut aider à réduire mais garde en tête que chaque image que tu ajoutes augmentera d'autant la taille de ton fichier.

Tu n'es qu'au début de ton fichier, réfléchi bien, une fois que tu seras vraiment lancé, il est parfois difficile de faire un retour en arrière.

++
Qwaz

**cobra38** · 05/05/2025, 12h19

Merci encore Qwazerty

je vais tenter de faire un classeur "article" puis gérer les années séparément
l'ennui c'est que je n'ai pas toute la connaissance pour bien structurer mes fichiers ....

bravo pour ta patience

Bonne Journée
pascal

**cobra38** · 09/05/2025, 17h47

Re Bonjour Qwazerty

Tu vas rire , j'ai tenté de séparer ma base "article" (base) de ma base "commande" (test4)
mais j'ai échoué

je ne sais plus comment faire pour indiquer à Excel que la base "article" est désormais externe et naturellement la fonction explicit ne fonctionne plus
donc si on a une structure ( dans le même répertoire) avec :
un fichier nommé Base qui comporte une feuille appelée "F-Base"
et un fichier nommé TestV4 qui comporte une feuille appelée "Feuil3" qui liste les commandes
comment fait-on pour lier les deux dans la fonction explicit de la feuil3 ? stp

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
Option Explicit

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim S As Variant
Dim FindRg As Range
Dim memoSU As Boolean

    'Initialisation
    'En cas d'erreur, on passe à la ligne suivante sans déclencher de message
    On Error Resume Next
    'On pointe les cellules présente dans la selection et dans la 1ère colonne du tableau
    Set FindRg = Intersect(Target, Sh.ListObjects(1).ListColumns(1).Range)
    
    'En cas d'erreur, on bascule directemnt à la fin
    On Error GoTo fin
    
    'On mémorise la position de screenupdating
    memoSU = Application.ScreenUpdating
    
    'On ne rafraichi plus l'écran
    Application.ScreenUpdating = False
    
    'On vérifie qu'il ne s'agit pas de la feuille base de données (à adapter pour cibler que les feuilles qui doivent faire l'objet d'un import d'image)
    'On regarde aussi qu'il n'y a qu'une cellule modifiée et qu'elle se trouve dans la 1ère colonne de la feuille
    If Sh.CodeName <> "Base!F_Base" And (Not FindRg Is Nothing) And Target.Count = 1 Then
        '-- suppression
        'On boucle sur toute les images présentes
        For Each S In Sh.Shapes
            If S.Type = 13 Or S.Type = 9 Then
                'On regarde si l'adresse de la cellule qui contient cette image correspond à la cellule à droite de Target, si c'est le cas, on la supprime
                If S.TopLeftCell.Address = Target.Offset(0, 1).Address Then
                    'On supprime l'image
                    S.Delete
                    'Si target est vide, on supprime la ligne
                    If Target.Value = "" Then
                        'On faire la correspondance en terme de ligne dans le tableau structuré
                        With Sh.ListObjects(1)
                            'Avant de supprimer la ligne, on s'assure qu'il ne s'agit pas de la dernière ligne vide du tableau!
                            'On prend le numero de ligne contenant target et on lui soustrait le numero de ligne où se trouve l'entête du tableau
                            'On pointe la ligne du tableau structuré correspondante
                            With .ListRows(Target.Row - .HeaderRowRange.Row)
                                'On vérifie qu'il ne s'agit pas de la dernière ligne du tableau
                                If .Index < Sh.ListObjects(1).ListRows.Count Then
                                    'On supprime la ligne
                                    .Delete
                                    'On quite la boucle For (Target n'existe plus)
                                    GoTo TargetKilled
                                End If
                            End With
                        End With
                    End If
                End If
            End If
        Next
        
        'Si Target est vide, on ne remet pas d'image
        If Target <> "" Then
            'On recheche la correspondance dans le tableau Base de donnée
            Set FindRg = Base!F_Base.ListObjects("Tab_Base").ListColumns(1).Range.Find(Target, LookAt:=xlWhole)
            'On place une copie de l'image Vide
            Base!F_Base.Shapes("Img_Vide").Copy
            Target.Offset(0, 1).PasteSpecial
            
            'On s'assure qu'une correspondance à été trouvée, sinon on laisse vide
            If Not FindRg Is Nothing Then
                'On place en formule, le lien vers la cellule dont on veut capturer l'apparence
                Selection.Formula = FindRg.Offset(0, 2).Address(External:=True)
            End If
                
            'On laisse du temps à Windows/Excel de faire le boulot
            DoEvents
            'On rétablie la dimension de l'image
            With Selection.ShapeRange
                .ScaleHeight 1, msoTrue
                .ScaleWidth 1, msoTrue
                'On affine la mise en place
                .Left = Target.Offset(0, 1).Left + 7
                .Top = Target.Offset(0, 1).Top + 5
                'On adapte la taille de la ligne
                Target.RowHeight = .Height + 10
            End With

        End If
        
TargetKilled:
        'On regarde si la dernière ligne du tableau à une cellule vide, sinon, on ajoute une ligne pour bénéficier de la liste déroulante la prochaine fois
        With Sh.ListObjects(1)
            'On s'assure qu'il existe du contenu dans le tableau
            If .ListRows.Count > 0 Then
                'On vérifie si la 1ère cellule de la dernière ligne contient du text
                If .ListRows(.ListRows.Count).Range(1).Value <> "" Then
                    'On ajoute une ligne vide
                    .ListRows.Add
                End If
            Else
                'On ajoute une ligne pour que le tableau est au moins une ligne vide
                .ListRows.Add
            End If
        End With
    End If
fin:
    'On rétabli la rafraichissement d'écran*
    Application.ScreenUpdating = memoSU
    
    'On affiche l'erreur si présente
    If Err.Number <> 0 Then
        MsgBox "L'erreur suivante est apparue" & vbCrLf & Err.Number & vbCrLf & Err.Description, vbCritical, "Erreur"
        Err.Clear
        'Resume
    End If
End Sub

Mille et uns mercis
pascal

**Qwazerty** · 09/05/2025, 20h22

Salut

Comme expliqué dans un de mes messages au dessus, il n'est pas possible de conserver le même fonctionnement avec un base à part. Tu ne pourras pas importer les visuels d'un fichier à un autre, ça serait trop lourd à gérer.

Je ne souhaite pas m'investir plus, je sens le gros fichier qui prend du temps, pour un truc commercial qui à mon avis existe déjà en vrai logiciel. On est déjà à 36 posts sans savoir exactement ce que tu veux faire. Tu devrais déjà réfléchir sur papier à comment organiser tes données avant de te lancer dans du code pour du code.

Si tu veux faire simple, avec un seul fichier

Un onglet base (comme l'existant)
Un onglets Commandes, qui regroupe toutes les commandes (N° Commande, Date Comamand, Client, N° Article, Quantité, Prix, ... un truc comme ça)
Un dernier onglet avec ton visuel de facturation.
1. Dans cette onglet, un système de sélection (N° Facture par exemple) -> remplissage des info + un tableau contenant les articles et là, tu affiches tes visuelles
2. Pour facilité la sélection tu peux scinder ta table Commande en 2
  1. Table1 = N° Commande, Date Comamand, Client
  2. Table2 = N° Commande,Client, N° Article, Quantité, Prix, ...
  3. Tu te sert de ta table1 que tu filtres pour trouver ta commande, double-clique sur la commande -> création de ta facture/commande dans un autre onglet [J'ai pensé à ce système suite à la discussion sur un autre, où Philippe Tulliez à proposé une solution de ce style] Tu peux même t'en servir pour faire un export vers un document Word avec ta tableau contenant les articles de ta commande avec les visuels.

C'est une solution qui me semble être la plus simple à mettre en œuvre

Une autre, peut-être un peu plus complexe (et encore que...), serait de faire ta base avec uniquement des chemins vers les images (que tu placerais dans un répertoire "images" à part). C'est la solution que j’évoquai plus haut mais qui nécessite une refonte complète du code, pour aller chercher les image dans le rép où elles se trouve. Dans une telle solution, tu aurais

Base.xlsx avec N° Article, Chemin image,...
Fichier commande avec import des données contenu dans Base via PQ + une ou deux tables comme vu au dessus (Par exemple Table 1 =Détail Commandes + Table2= Contenu commandes. Power Query te ferait le JOIN entre les deux tables). Le code VBa serait chargé d'importer les visuels lorsque tu choisis d'afficher une des commandes, ça évite de te trimbaler avec des images partout pour rien (fichier moins volumineux, traitement des données plus rapide et moins complexe qu'avec des image inclus dans un fichier).
De plus, si un visuel ne te plait plus, tu le modifies au niveau de ton répertoire images, tu affiches de nouveau ta facture... le nouveau visuel est prit en compte.

++
Qwaz

**cobra38** · 09/05/2025, 22h39

Salut ,

je voulais juste savoir à partir de l'exemple TestV4 et de la base comment on faisait pour aller chercher une base externe mais je me suis peut-être mal exprimé et m'en excuse par avance
il n'a jamais été question ici de "base commercial" , elle est simplement "personnelle" et çà reste en ce qui me concerne un simple exercice VBA
pour gérer quelques composants, mais comme j'ai beaucoup perdu en pratique je réapprends...

je te remercie encore

Bonne soirée
pascal

**Qwazerty** · 09/05/2025, 22h46

Salut

Comme dis dans mon message au dessus, ça n'est pas possible de le faire avec un base.xlsx contenant des images.

Pour faire un import de données avec PowerQuery, Ruban Donnée, Obtenir les données, à partir d'un fichier Excel....

++
Qwaz

**cobra38** · 09/05/2025, 23h10

Ok
merci bien , pardon pour le dérangement

Bonne soirée
pascal

Afficher des images [XL-2016]

Excel

Discussions similaires

Partager

Partager