Image en fonction de la valeur d'une cellule
Bonjour,
Si Arturo passe par ici, est-ce que le code actuellement dans le dernier classeur disponible sur We transfert est viable
Malgré plusieurs tentatives, impossible à ouvrir de mon côté, peut-être dû à ma version excel trop ancienne (2007) et incompatible avec certains éléments que comporte votre fichier. Sinon, déposez uniquement le code et en signalant au passage la ligne qui génère le message d'erreur.
Cdlt
Bonjour Arturo, la ligne en question est la suivante :
If Not Intersect(Target, Range(Plage)) Is Nothing ThenJe pense que c'est parce qu'il n'y a pas de plage défini pour cette ligne, du moins que les feuilles "index des menus", "paramètres, et "Aide" ne sont pas exclue du code VBA (c'est mon analyse de non initié au VBA :D )
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
'Déclaration des variables
Dim f1 As Worksheet, f2 As Worksheet
Dim Sht As Variant
Dim item As String
Dim Nb_Sht As Long, Position As Long
Dim Plage As String
Application.ScreenUpdating = False
Select Case ActiveSheet.Name
Case Is = "Lycée Saint Genès"
Plage = "A28:DU28"
Case Is = "Collège Saint Michel"
Plage = "A19:DU19"
Case Is = "Collège Le Mirail"
Plage = "A24:DU24"
Case Is = "O'PTIMÔMES"
Plage = "A19:DU19"
Case Is = "Collège Bremontier"
Plage = "A22:DU22"
Case Is = "IDB - IME SAVIO & VILLAS"
Plage = "A19:DU19"
Case Is = "IDB - IME Villa SAISP"
Plage = "A19:DU19"
Case Is = "DIACONAT"
Plage = "A20:DU20,A42:DU42"
Case Is = "IDB - CRFP"
Plage = "A20:DU20,A42:DU42"
Case Is = "IDB - FOYER"
Plage = "A20:DU20,A42:DU42"
Case Is = "IDB - IME Saute Mouton"
Plage = "A22:DU22,A43:DU43"
Case Is = "IDB - SELF"
Plage = "A24:DU24"
End Select
If Not Intersect(Target, Range(Plage)) Is Nothing Then
Set f1 = Sheets("Paramètres") 'on affecte la variable f1 à la feuille "Paramètres"
Set f2 = Sheets(ActiveSheet.Name) 'on affecte la variable f1 à la feuille destination
Position = 0 'on initialise la position à 0 le bord gauche de la cellule de destination
Nb_Sht = 0 'on initialise le compteur d'image à 0
For Each Sht In ActiveSheet.Shapes 'pour chaque image trouvée dans la feuille
On Error Resume Next 'si on détecte une erreur,on passe à la ligne suivante
'*************************************************************************************************************
'si l'adresse de la cellule trouvée qui contient une image correspond à l'adresse de la cellule de destination _
ou si l'image empiète sur la cellule du dessus et celle de gauche, alors
If Sht.TopLeftCell.Address = f2.Cells(Target.Row - 1, Target.Column).Address Or _
Sht.TopLeftCell.Address = f2.Cells(Target.Row - 1, Target.Column - 1).Address Then
If Err.Number = 0 Then 's'il n'y a pas d'erreur
Nb_Sht = Nb_Sht + 1 'on incrémente le compteur d'image
Else
On Error GoTo 0 'on réinitialise la gestion d'erreur
End If
End If
Next Sht 'on cherche l'image suivante
Suite:
If Nb_Sht > 0 Then Position = Position + (50 * Nb_Sht) 'si le nombre d'image trouvée est supérieur à 0
item = Replace(Target, " ", "_") 'on prend le nom sélectionné dans la liste déroulante et on remplace les espaces par des tirets "soulignés"
Sht = Application.Match(Target, f1.Range("A1:A30"), 0) 'on recherche le nom de l'image dans la feuille paramètre
f1.Shapes(item).Copy 'on copie l'image trouvée
f2.Select
ActiveSheet.Paste Cells(Target.Row - 1, Target.Column) 'on la colle en haut et à gauche dans la cellule de destination
'positionnement de l'image
With ActiveSheet.Shapes(item)
.Top = Cells(Target.Row - 1, Target.Column).Top + 7 'on décale vers le bas pour centrer l'image verticalement dans la cellule de destination
.Left = Cells(Target.Row - 1, Target.Column).Left + 100 'on décale vers la droite autant de fois qu'il y a d'image trouvée, pour ne pas qu'elles se chevauchent
End With
'on renomme l'image(avec l'heure) pour le cas où on en ajouterait une autre identique et que le programme ne vienne pas la déplacer _
elle aussi puisqu'elle porterait le même nom que la dernière sélectionnée. _
Ainsi toutes les images sont uniques.
ActiveSheet.Shapes(item).Name = Time 'on renomme l'image pour le cas où une prochaine image identique dans la feuille, qu'elle ne soit pas déplacer elle aussi
End If
End SubEst-ce que tu souhaite avoir le classeur sous une autre forme ?
Il suffit d'ajouter un cas d'exclusion "Case Else" et de sortir de la macro si ce n'est pas la bonne feuille.
Select Case ActiveSheet.Name
Case Is = "Lycée Saint Genès"
Plage = "A28:DU28"
Case Is = "Collège Saint Michel"
Plage = "A19:DU19"
Case Is = "Collège Le Mirail"
Plage = "A24:DU24"
Case Is = "O'PTIMÔMES"
Plage = "A19:DU19"
Case Is = "Collège Bremontier"
Plage = "A22:DU22"
Case Is = "IDB - IME SAVIO & VILLAS"
Plage = "A19:DU19"
Case Is = "IDB - IME Villa SAISP"
Plage = "A19:DU19"
Case Is = "DIACONAT"
Plage = "A20:DU20,A42:DU42"
Case Is = "IDB - CRFP"
Plage = "A20:DU20,A42:DU42"
Case Is = "IDB - FOYER"
Plage = "A20:DU20,A42:DU42"
Case Is = "IDB - IME Saute Mouton"
Plage = "A22:DU22,A43:DU43"
Case Is = "IDB - SELF"
Plage = "A24:DU24"
Case Else
Exit Sub
End SelectEdit:
on peut aussi simplifier votre code comme ceci:
Select Case ActiveSheet.Name
Case Is = "Lycée Saint Genès"
Plage = "A28:DU28"
Case Is = "Collège Le Mirail", "IDB - SELF"
Plage = "A24:DU24"
Case Is = "IDB - IME SAVIO & VILLAS", "IDB - IME Villa SAISP", "O'PTIMÔMES"
Plage = "A19:DU19"
Case Is = "DIACONAT", "IDB - CRFP", "IDB - FOYER", "Collège Saint Michel"
Plage = "A20:DU20,A42:DU42"
Case Is = "IDB - IME Saute Mouton", "Collège Bremontier"
Plage = "A22:DU22,A43:DU43"
Case Else
Exit Sub
End SelectJ'AVAIS DONC VU JUSTE ????????!!!!!!
Pardon pour cette euphorie trop brusque et inappropriée.
C'est parfait ça fonctionne correctement.
Que dois-je ajouter au code pour que ce dernier me supprime automatiquement l'image présente dans la cellule avant de placer la nouvelle (puisque au dernière nouvelle nous somme bien sur 1 seul image par cellule) ?
edit :
les valeur correcte sont les suivantes :
Select Case ActiveSheet.Name
Case Is = "Lycée Saint Genès"
Plage = "A28:DU28"
Case Is = "Collège Saint Michel", "O'PTIMÔMES", "IDB - IME Villa SAISP", "IDB - IME SAVIO & VILLAS"
Plage = "A19:DU19"
Case Is = "Collège Le Mirail", "IDB - SELF"
Plage = "A24:DU24"
Case Is = "Collège Bremontier"
Plage = "A22:DU22"
Case Is = "DIACONAT", "IDB - CRFP", "IDB - FOYER"
Plage = "A20:DU20,A42:DU42"
Case Is = "IDB - IME Saute Mouton"
Plage = "A22:DU22,A43:DU43"
Case Else
Exit Sub
End SelectLa première partie du code incluant l'effacement de l'image déjà présente
Application.ScreenUpdating = False
Select Case ActiveSheet.Name
Case Is = "Lycée Saint Genès"
Plage = "A28:DU28"
Case Is = "Collège Le Mirail", "IDB - SELF"
Plage = "A24:DU24"
Case Is = "IDB - IME SAVIO & VILLAS", "IDB - IME Villa SAISP", "O'PTIMÔMES"
Plage = "A19:DU19"
Case Is = "DIACONAT", "IDB - CRFP", "IDB - FOYER", "Collège Saint Michel"
Plage = "A20:DU20,A42:DU42"
Case Is = "IDB - IME Saute Mouton", "Collège Bremontier"
Plage = "A22:DU22,A43:DU43"
Case Else
Exit Sub
End Select
'***********************************************************************************
'effacement des images précédentes dans la cellule
Set f2 = Sheets(ActiveSheet.Name) 'on affecte la variable f1 à la feuille destination
For Each Sht In ActiveSheet.Shapes
On Error Resume Next
If Sht.TopLeftCell.Address = f2.Cells(Target.Row - 1, Target.Column).Address Or _
Sht.TopLeftCell.Address = f2.Cells(Target.Row - 1, Target.Column - 1).Address Then
If Err.Number = 0 Then
Sht.Delete
Else
On Error GoTo 0
End If
End If
Next Sht
'***********************************************************************************
If Not Intersect(Target, Range(Plage)) Is Nothing Then
Set f1 = Sheets("Paramètres") 'on affecte la variable f1 à la feuille "Paramètres"
Position = 0 'on initialise la position à 0 le bord gauche de la cellule de destination
Nb_Sht = 0 'on initialise le compteur d'image à 0
For Each Sht In ActiveSheet.Shapes 'pour chaque image trouvée dans la feuille
On Error Resume Next 'si on détecte une erreur,on passe à la ligne suivante
'*************************************************************************************************************
'si l'adresse de la cellule trouvée qui contient une image correspond à l'adresse de la cellule de destination _
ou si l'image empiète sur la cellule du dessus et celle de gauche, alors
If Sht.TopLeftCell.Address = f2.Cells(Target.Row - 1, Target.Column).Address Or _
Sht.TopLeftCell.Address = f2.Cells(Target.Row - 1, Target.Column - 1).Address Then
If Err.Number = 0 Then 's'il n'y a pas d'erreur
Nb_Sht = Nb_Sht + 1 'on incrémente le compteur d'image
Else
On Error GoTo 0 'on réinitialise la gestion d'erreur
End If
End If
Next Sht 'on cherche l'image suivante
Suite:Bonsoir YouniCornnn, Le Forum,
j'aimerais un jour atteindre ce niveau ! Chapeau bas !!
Merci à tous pour vos encouragements... qui me poussent à modifier plus vite le fichier.
@YouniCornnn, ne te découvre pas trop la tête
@BrunoM45, il n'est pas nécessaire d'utiliser un formulaire pour le Contrôle ImageList.
Mais l'intégrer (après l'avoir coché) dans la Boîte à Outils comme contrôle supplémentaire. Cela devrait suffire à l'exploiter mieux.
Voici la version 3 du classeur. Avec le "swap" par le ComboBox de l'image si l'utilisateur s'est trompé dans le choix du pictogramme.
Maintenant ils sont au nombre d'une vingtaine dans l'imageList.
Plus un nouveau bouton (procédure placement) afin de permettre à l'utilisateur de bouger le picto dans sa cellule pour le placer selon sa convenance.
Voir notes en rouge plus exhaustives.
Je vous remercie pour votre aide !
J'ai malheureusement eu beaucoup de changement au niveau vie perso, et j'ai un peu zappé de clôturer ce sujet.
Je vais en ouvrir un de nouveau pour les curieux (un beaucoup plus simple normalement).