Importer images selon caractères d'une case

Est-ce que tu as des connaissances en VBA (macros) ?

Si oui je te donne les astuces, si non je te fais le code :)

Euh, pas beaucoup ! j'ai bidouillé le code moi même, mais ça s'arrête là ! je ne connais pas assez bien les fonctions !

enfin je veux dire, à l'origine le code n'était pas comme ça(ce n'est pas moi qui l'ai fait), je l'ai adapté à mon cas, mais j'arrive pas à l'optimiser !

Alors je peux vous faire le code ce soir, si vous êtes patient ou si personne ne répond avant.

En faite il faut juste me dire quand est-ce que Excel doit aller chercher cette image (Quand on active une feuille, quand on appuie sur un bouton, quand on ajoute du text à une cellule) et ou est-ce qu'il doit aller chercher ces images (Le chemin exacte)

Après je peux faire le reste seul :)

REF = toujours information en G6 que je saisis manuellement
COL = information en C22 (pour case jaune en B28) G22 (pour case jaune en F28) ect...
Les informations en C22, G22... arrivent automatiquement grâce à une macro d'extraction lorsque je rentre le code en G6. A partir du moment où la case est remplie, la fonction photo fiche s'active (c'est actuellement ce que fait le code). Parfois la case C22, G22... est vide. les cases B28, F28... sont alors sous la forme REF_

Actuellement le chemin est inscrit en case B3 de la feuille paramètre. Je ne peux malheureusement pas vous donner le chemin car il y a des informations confidentielles dessus... mais s'il s'agit uniquement de copier le chemin en B3 ce sera bon pour moi ! (je pense que c'est ce que fait le code actuellement)

Merci beaucoup de votre aide !

Voici ce que ça donnerait:

https://www.cjoint.com/?0HzqcSz1JuN

Je ne sais pas si mon fichier est très clair !

Bonjour,

La solution a été trouvée, merci !

Je suis désolé je n'ai pas eu le temps de me plongé la dessus. Je vais essayer de ragerder ce week-end.

Ne vous embêtez pas, la solution a déjà été trouvé ! Merci beaucoup en tout cas !

Super alors vous pouvez mettre le sujet comme résolu alors :)

(pensez à expliquer votre solution )

Encore désolé

Bonjour,

Voici la solution qui a été trouvée :

Sub Insertion_Image()
Dim Ligne As Long, Colonne As Integer
Dim Image As Shape
Dim Chemin As String, Fichier As String
Dim AdImage As String, Nom As String
Dim iPict As IPictureDisp 'Récupération des dimensions de l'image
Dim NomFichier As String
Dim WiPict As Double, HiPict As Double, t As Double, l As Double, w As Double, h As Double
Dim hImgInit As Double, wImgInit As Double, hImgCoef As Double, wImgCoef As Double

Application.ScreenUpdating = False 'Bloque la mise à jour de l'écran
For Each Image In ActiveSheet.Shapes
If Image.Type = msoPicture Then
Debug.Print Image.TopLeftCell.Address, Image.Name
Image.Delete
End If
Next Image

On Error GoTo Erreur 'Gestion des erreurs, renvoir à l'étiquette Erreur
Chemin = Sheets("PARAMETRES").Range("B3").Value 'Définition du nom et du chemin d'acces à l'imagette
For Ligne = 28 To 80 Step 13
For Colonne = 2 To 6 Step 4

Nom = Cells(Ligne, Colonne) & ".jpg"
AdImage = Chemin & Nom

If Dir(AdImage) <> "" Then
Set iPict = LoadPicture(AdImage)
WiPict = iPict.Width
HiPict = iPict.Height

With Cells(Ligne, Colonne) 'Détermine la position et la dimension de la cellule active
t = .Top
l = .Left
w = .Columns.Width * 2
h = .Rows.Height * 10
End With

Set Image = ActiveSheet.Shapes.AddPicture(AdImage, False, True, l, t, WiPict, HiPict)

With Image
hImgInit = Image.Height 'Détermine la dimension initiale de l'imagette
wImgInit = Image.Width

.Top = h 'Positionne l'imagette dans la cellule active
.Left = l + 1 'Positionne l'imagette dans la cellule a gauche (ak)
.Placement = xlMoveAndSize 'Locks the image so it can be sorted (ak)

hImgCoef = hImgInit / h 'Calcul des coefficients de réduction de l'imagette ( hauteur et largeur )
wImgCoef = wImgInit / w

If wImgInit < hImgInit Then 'Condition pour choisir le coefficient de réduction le plus grand
.Height = h - 2 'Réduction de l'imagette si le coefficient en hauteur est plus grand
.Width = (wImgInit / hImgCoef) - 0
.Top = t - h / 2 'Positionne l'imagette dans la cellule active
.Left = l 'Positionne l'imagette dans la cellule a gauche (ak)
.Placement = xlMoveAndSize
Else
.Height = (hImgInit / wImgCoef) - 0 'Sinon réduction de l'imagette avec le coefficient en largeur
.Width = w - 0
.Top = t - (hImgInit / wImgCoef) / 2 'Positionne l'imagette dans la cellule active
.Left = l 'Positionne l'imagette dans la cellule a gauche (ak)
.Placement = xlMoveAndSize
End If

End With
End If
Next Colonne
Next Ligne

Set iPict = Nothing
Set iPict = Nothing

Application.ScreenUpdating = True 'Réactivation de la mise à jour de l'écran
Exit Sub 'Sortie de la fonction

Erreur: 'Gestion de l'erreur si le chemin n'est pas valide
MsgBox "Pas d'image nommée " & Nom & " dans ce répertoire", vbExclamation, Chemin

End Sub