VBA, comment insérer des images dans des cellules fusionnées ave [Résolu/Fermé]

Signaler
Messages postés
6
Date d'inscription
mercredi 14 janvier 2015
Statut
Membre
Dernière intervention
20 janvier 2015
-
Messages postés
6
Date d'inscription
mercredi 14 janvier 2015
Statut
Membre
Dernière intervention
20 janvier 2015
-
Bonjour,

URGENT !

Je suis une étudiante et je dois rédiger un travail de diplôme et insérer un grand nombre d'images dans des cellules fusionnées et je cherche une macro qui pourrait m'aider à les insérer automatiquement.

Elles sont dans les 2 formats (paysage et portraits) de grandeur différente (cellules fusionnées) et mon fichier excel 2010 comprend 15 onglets différents qui contiendront la plupart des images. Je souhaiterais - pour faire joli - qu'une bordure grise de 0.5 points entoure chaque image. Il faudrait aussi que les images importées restent sur le fichier si je change de dossiers.

Est-ce possible ?

J'espère que oui et j'envoie déjà tous mes remerciements à la personne qui pourra m'aider.

12 réponses

Messages postés
15261
Date d'inscription
dimanche 25 novembre 2007
Statut
Membre
Dernière intervention
5 août 2020
1 319
Bonjour,

je dois rédiger un travail de diplôme Oui, si vos images ne changent pas apres insertion pas besoin de macro pour les inserer, il faut le faire manuellement
1
Merci

Quelques mots de remerciements seront grandement appréciés. Ajouter un commentaire

CCM 56897 internautes nous ont dit merci ce mois-ci

Messages postés
6
Date d'inscription
mercredi 14 janvier 2015
Statut
Membre
Dernière intervention
20 janvier 2015
1
Merci pour ton aide. J'ai testé ton code et cela ne fonctionne pas, dsl ! Y faut dire que je suis une étudiante en économie et une pomme en informatique !

Sur Internet, j'ai trouvé un code qui fonctionne super, mais dès que je déplace le fichier, les images ne suivent pas et en plus, je n'arrive pas à mettre une bordure autour de celle-ci !

Sub InsererImage()

Dim myPicture As String, MyRange As Range
myPicture = Application.GetOpenFilename _
("Pictures (.bmp; .gif; .jpg; .png; .tif),.bmp; .gif; .jpg; .png; .tif", _
, "Select Picture to Import")

Set MyRange = Selection
InsertAndSizePic MyRange, myPicture
End Sub


Sub InsertAndSizePic(Target As Range, PicPath As String)

Dim p As Picture
Application.ScreenUpdating = False

On Error GoTo EndOfSubroutine:
Set p = ActiveSheet.Pictures.Insert(PicPath)

If Target.Cells.Count = 1 Then Set Target = Target.MergeArea
With Target
p.Left = .Left
p.Width = .Width
End With

EndOfSubroutine:
End Sub
1
Merci

Quelques mots de remerciements seront grandement appréciés. Ajouter un commentaire

CCM 56897 internautes nous ont dit merci ce mois-ci

Messages postés
1939
Date d'inscription
lundi 3 mai 2010
Statut
Membre
Dernière intervention
29 juillet 2020
134
Bonjour,

Oui, les images restent dans le fichier et ne sont pas appelées (comme ça le serait dans une page web classique).
Même si j'aime bien Excel, je trouve ça curieux de rédiger un document si massif sous Excel.
Tu peux insérer toutes tes images en même temps et définir la bordure pour toutes les images en même temps (toutes images sélectionnées, clic droit, etc.).

Je suis d'accord avec f894009 ; qu'apporterait la macro ? Il faudrait indiquer à la macro quelles images importer et où les placer. C'est plus pénible que de le faire à la souris.

Ce qui peut être intéressant pour toi par macro doit être le redimensionnement (taille et poids du fichier). Des topics existent déjà sans doute sur ce sujet.

A+
Messages postés
6864
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
5 août 2020
535
Bonjour,

Tout a fait d'accord avec vous 2 . Je me suis amusé a faire une macro pour insérer une image dans des cellules fusionnées limitées a une plage.

Comme le dit si bien Zoul67:

Ce qui peut être intéressant pour toi par macro doit être le redimensionnement

Voici le code de recherche du fichier image et redimensionnement suivant les cellules fusionnées:

Option Explicit
Dim cheminfichier As Variant
Dim position
Private Sub CommandButton1_Click()
open_file
detecteFusion
End Sub
Sub detecteFusion()
Dim cellule
 For Each cellule In Range("A1:M28") 'plage de recherche a adapter
 If Range(cellule.Address).MergeCells Then
 cellule.Select
 position = cellule.Address
 InsertImage
 End If
 Next cellule
 End Sub
Sub InsertImage()
If cheminfichier = "" Then Exit Sub
ActiveSheet.Pictures.Insert(cheminfichier).Select
With Selection.ShapeRange
        .LockAspectRatio = msoFalse
        .Left = ActiveCell.Left
        .Top = ActiveCell.Top
        .Width = ActiveCell.Width * 2 'a adapter suivant les cellules fusionnées
        .Height = ActiveCell.Height
    End With
With Worksheets(1).Range(position)
   With .Borders(xlEdgeLeft)
        .LineStyle = xlDouble 'bordure double
        .Weight = xlMedium 'trait moyen
        .Color = RGB(255, 0, 0) 'rouge
    End With
    With .Borders(xlEdgeRight)
        .LineStyle = xlDouble
        .Weight = xlMedium
        .Color = RGB(255, 0, 0)
    End With
    With .Borders(xlEdgeTop)
        .LineStyle = xlDouble
        .Weight = xlMedium
        .Color = RGB(255, 0, 0)
    End With
    With .Borders(xlEdgeBottom)
        .LineStyle = xlDouble
        .Weight = xlMedium
        .Color = RGB(255, 0, 0)
    End With
   End With
End Sub
Sub open_file()
'Declare a variable as a FileDialog object.
    Dim fd As FileDialog
   'Create a FileDialog object as a File Picker dialog.
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
'Declare a variable to contain the path
    'of each selected item. Even though the path is a String,
    'the variable must be a Variant because For Each...Next
    'routines only work with Variants and Objects.
    Dim vrtSelectedItem As Variant
'Use a With...End With block to reference the FileDialog object.
    With fd
'Add a filter that includes GIF and JPEG images and make it the first item in the list.
        .Filters.Add "Images", "*.gif; *.jpg; *.jpeg", 1
        .Title = "Choisissez une image"
        .InitialFileName = "C:\"
        .InitialView = msoFileDialogViewThumbnail 'afficher les miniatures

        'Use the Show method to display the File Picker dialog box and return the user's action.
        'If the user presses the action button...
        If .Show = -1 Then

            'Step through each string in the FileDialogSelectedItems collection.
            For Each vrtSelectedItem In .SelectedItems

                'vrtSelectedItem is a String that contains the path of each selected item.
                'You can use any file I/O functions that you want to work with this path.
                'This example simply displays the path in a message box.
               cheminfichier = vrtSelectedItem
               Next
               End If
               End With
End Sub


Messages postés
6864
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
5 août 2020
535
Mettre dans la feuille concernée en haut à gauche:

Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
position = Target.Address
End Sub


Inserer un module et mettre ceci:

Option Explicit

Public position As String


et voici ton code avec les bordures et l'image dimensionnée à la cellule fusionnée:

Option Explicit
Private Sub CommandButton1_Click()
InsererImage
End Sub
Sub InsererImage()
Dim cellule
 Dim myPicture As String, MyRange As Range
 myPicture = Application.GetOpenFilename _
 ("Pictures (.bmp; .gif; .jpg; .png; .tif),.bmp; .gif; .jpg; .png; .tif", _
 , "Select Picture to Import")
Set MyRange = Selection
InsertAndSizePic MyRange, myPicture
 With Worksheets(1).Range(position)
   With .Borders(xlEdgeLeft)
        .LineStyle = xlDouble 'bordure double
        .Weight = xlMedium 'trait moyen
        .Color = RGB(255, 0, 0) 'rouge
    End With
    With .Borders(xlEdgeRight)
        .LineStyle = xlDouble
        .Weight = xlMedium
        .Color = RGB(255, 0, 0)
    End With
    With .Borders(xlEdgeTop)
        .LineStyle = xlDouble
        .Weight = xlMedium
        .Color = RGB(255, 0, 0)
    End With
    With .Borders(xlEdgeBottom)
        .LineStyle = xlDouble
        .Weight = xlMedium
        .Color = RGB(255, 0, 0)
    End With
   End With
End Sub
Sub InsertAndSizePic(Target As Range, PicPath As String)
Dim p As Picture
 Application.ScreenUpdating = False
On Error GoTo EndOfSubroutine:
 Set p = ActiveSheet.Pictures.Insert(PicPath)
If Target.Cells.Count = 1 Then Set Target = Target.MergeArea
With Target
        p.Left = .Left
        p.Top = .Top
        p.Width = .Width
    End With
EndOfSubroutine:
End Sub


Il faudra juste sélectionner la cellule avant de lancer la macro.
Pour plus de facilité tu vas dans les propriétés de ton UserForm et tu mets :

ShowModal a False

Si tu as des difficulté je mettrais le fichier sur cjoint
Messages postés
6864
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
5 août 2020
535
mais dès que je déplace le fichier, les images ne suivent pas

Je ne comprends pas. Que veux-tu dire par là? Les images que tu as insérées restent sur la feuille et ne sont pas attachées à leur emplacement d'origine
Messages postés
6864
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
5 août 2020
535
Si tu change de feuille, il faudra mettre ce code dans toutes tes feuilles:

Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
position = Target.Address
End Sub


Changer cette ligne dans le code d'insertion d'image: Sub InsererImage()

With Worksheets(1).Range(position)


par

 With ActiveSheet.Range(position)



Messages postés
6
Date d'inscription
mercredi 14 janvier 2015
Statut
Membre
Dernière intervention
20 janvier 2015
1
Re bonjour,

J'accepte avec plaisir ton offre de mettre le fichier sur cjoint et en attendant, je t'envoie ce tout grand MERCI pour ton aide !ü

@+ Rose
Messages postés
6864
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
5 août 2020
535
Voici le lien:

http://www.cjoint.com/data3/3AqlKJqtWBV.htm
Messages postés
6
Date d'inscription
mercredi 14 janvier 2015
Statut
Membre
Dernière intervention
20 janvier 2015
1
Re re bonjour,

C'est super ! je vais profiter du week-end pour mettre tout cela en place !

Encore un énoooooooooooorme MERCI et un tout beau week-end à toi.

@+ Rose
Messages postés
6
Date d'inscription
mercredi 14 janvier 2015
Statut
Membre
Dernière intervention
20 janvier 2015
1
Re, re et re,

Tout d'abord un tout grand MERCI pour ta peine. J'ai testé ton fichier, c'est "TOP", ça marche tip-top, mais ça se gâte toutefois, quand je l'importe sur mon fichier, car j'ai une erreur qui apparaît sur la ligne que j'ai marqué en gras:

ub InsererImage()
Dim myPicture As String, MyRange As Range
myPicture = Application.GetOpenFilename _
("Pictures (.bmp; .gif; .jpg; .png; .tif),.bmp; .gif; .jpg; .png; .tif", _
, "Select Picture to Import")
Set MyRange = Selection
InsertAndSizePic MyRange, myPicture
With ActiveSheet.Range(position)


Que faire ?

... et puis, si tu pouvais regarder pour mettre un cadre autour de l'image, mais pas de la cellule !

Encore merci à toi et une toute belle journée.

cordialement.

A+ Rose
Messages postés
6864
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
5 août 2020
535
J'ai simplifié le code. Si tu veux changer la couleur du fond, tu te sers de l'enregistreur de macro pour avoir le code couleur:

http://www.cjoint.com/data3/3AtoeegU2Rv.htm
Messages postés
6
Date d'inscription
mercredi 14 janvier 2015
Statut
Membre
Dernière intervention
20 janvier 2015
1
Re, re, re, re et re,

Je ne sais comment te remercier ! C'est vraiment SUPER de chez SUPER !

Alors encore un tout grand MERCI et une toute belle fin de journée à toi !

Cordialement.

Rose