XL 2016 Placer mes photos dans la colonne A, [A3], [A4],etc, jusqu'en [A99] selon le prénom et le nom colonnes B et C

Créer une discussion
Répondre

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
W

Webperegrino

XLDnaute Accro
Supporter XLD
Bonsoir Le Forum,
Voici une série de lignes de VBA dans un fichier trop lourd pour vous le transmettre ici.
La ligne "PlaceThePictureInCenterRange Cells", au milieu de ce qui suit, est bloquant et je n'arrive pas à trouver la solution pour que les photos soient rapatriées de mon dossier TROMBINOSCOPE avec un chemin correct placé en cellule [AM1].
Pouvez-vous me trouver l'erreur, ou l'oubli dans la saisie ?
Merci
Webperegrino
VB: 
Sub CommandButton5_Cliquer()
'place les photos dans la colonne A (le prénom est en colonne B et le nom en colonne C
‘les photos dans TROMBINOSCOPE sont nommées Prénom + espace + Nom.JPG
[A3:A161].ClearContents: [A2] = 0
'placement des formules
Application.ScreenUpdating = True
[A3].FormulaLocal = "=NBVAL(B3)+A2*NBVAL(B3)"
'en ce qui concerne mon fichier actuel :
'en [A3] prend la valeur 1,
'en [A4] prend la valeur 2, etc ...
'jusqu'à la ligne 99 où [A99] prend la valeur 99
Range("A3").Copy Range("A4:A161")
'efface les photos éventuellement en place
Dim s As Shape
'Application.ScreenUpdating = False

For Each s In ActiveSheet.Shapes
  If Not Intersect(s.TopLeftCell, [A3:A161]) Is Nothing Then
    s.Delete
  End If
Next

'place les photos du TROMBINOSCOPE
Dim Row As Integer, col As Integer
Dim File As Variant, Fso As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
Application.ScreenUpdating = False
[A1] = 0
Row = 3
col = Columns("A").Column
[A3].FormulaLocal = "=NBVAL(B3)+A2*NBVAL(B3)"
PhotoDir = [AM1] & "TROMBINOSCOPE\"

For Row = 3 To 161
   For Each File In Fso.GetFolder([PhotoDir]).Files
     If File.Name Like "*.jpg" Then
        [A1] = [A1] + 1
        If Cells(Row, col + 1) & " " & Cells(Row, col + 2) = Fso.getBasename(File) Then

'la ligne suivante bloque la macro :
PlaceThePictureInCenterRange Cells(Row, col), Shapes.AddPicture(File, False, True, 20, 20, -1, -1), 90
' la photo .JPG n'apparaît pas dns la cellule...
'Je ne trouve pas l'erreur.

       End If
     End If
  Next
Next

Set Fso = Nothing ' Libération mémoire
Application.ScreenUpdating = True
End Sub
 
Solution
job75
Bonjour le forum,
Webperegrino à dit:
dans la zone A1, j'ai quelques boutons d'appel de macro... qui s'effacent à l'issue du fonctionnement de ces lignes vba.
Cliquez pour agrandir...
Ces instructions :
VB: 
    For Each s In .Shapes
        If Not Intersect(s.TopLeftCell, .Columns(1)) Is Nothing Then s.Delete 'RAZ
    Next s
suppriment toutes les Shapes de la colonne A donc aussi les boutons ActiveX ou de formulaire.

En fait ce qu'on veut supprimer ce sont les Pictures (images) créées il suffit donc de préciser le Type :
VB: 
Sub PlacerPhotos()
Dim chemin$, W#, s As Shape, lig&, fichier$
chemin = ThisWorkbook.Path & "\TROMBINOSCOPE\"
Application.ScreenUpdating = False
With ActiveSheet
    .Columns(1).ColumnWidth = 16 'largeur de colonne A à adapter
    W =...
Trier par date Trier par votes
Le Forum,
Bonsoir AtTheOne,
En effet le lien que vous me donnez est intéressant avec la commande "Placer l'image" dans la colonne G qui me parait complet pour m'aider à résoudre mon problème.
Demain, - il se fait un peu trad pour travailler - je vais étudier notamment #3 'Placer l'image" ... dans la colonne G.
C'est un peu ardu, mais je vais peut-être réussir à me débrouiller.
Merci pour votre entrée dans cette discussion.
Webperegrino
 
Vote positif 0 Vote négatif
Bonjour Webperegrino, AtTheOne, le forum,

Placer des photos dans des cellules est vraiment très simple, utilisez cette macro :
VB: 
Sub PlacerPhotos()
Dim chemin$, fichier$, W#, s As Shape, n%
chemin = ThisWorkbook.Path & "\TROMBINOSCOPE\"
fichier = Dir(chemin & "*.jpg") '1er fichier du dossier
Application.ScreenUpdating = False
With ActiveSheet
    .Columns(1).ColumnWidth = 12 'largeur de colonne A à adapter
    W = .Columns(1).Width 'largeur en points
    For Each s In .Shapes
        If Not Intersect(s.TopLeftCell, .Columns(1)) Is Nothing Then s.Delete 'RAZ
    Next s
    While fichier <> ""
        n = n + 1
        Set s = .Shapes.AddPicture(chemin & fichier, msoFalse, msoTrue, 0, .Rows(n + 2).Top, 0, 0)
        s.LockAspectRatio = True
        s.Width = W 'la photo prend la largeur de la cellule
        .Rows(n + 2).RowHeight = W * s.Height / s.Width + 0.7 'la cellule prend la hauteur de la photo + marge
        .Cells(n + 2, 2) = Left(fichier, Len(fichier) - 4) 'prénom et nom en colonne B
        fichier = Dir 'fichier suivant
    Wend
End With
End Sub
Mettez le fichier contenant la macro dans le dossier que vous voulez et dans ce dossier placez le dossier TROMBINOSCOPE des photos.

A+
 
Vote positif 0 Vote négatif
Le Forum,
Bonjour Job75, AtTheOne,
Merci Job75 pour cette proposition.
En effet le fichier destination se situe déjà dans le même dossier contenant le sous-dossier TROMBINOSCOPE : votre dernière condition de fonctionnement des lignes de macro est donc respectée.

J'ai un doute sur le collage de ces lignes dans mon fichier : en effet la feuille contient déjà le prénom en colonne B et le nom en colonne C avant de recevoir la photo en colonne A, .
La ligne 5 en partant du bas de la macro #4 n'est-elle pas superflue ?
Puis-je ne pas l'inscrire, et cette macro fonctionnerait quand même ?
"par comparaison du prénom en colonne A et du nom en colonne B de la feuille destination, la recherche de l'image prénom + blanc + nom dans TROMBINOSCOPE, fera que la photo .jpg se mettra en cellule A près du prénom et nom des deux colonnes voisines" fonctionnera bien ?
Je crains de faire une bêtise en laissant cette ligne "-5".

Je pensais voir une ligne du genre
If Not Intersect(s.TopLeftCell, .Columns(1)) then ... copie de la photo trouvée à gauche du prénom déjà en place.

Merci pour vos explications à venir.
Webêregrino
 
Vote positif 0 Vote négatif
Job75,
C'est logique (#7).
J'ai créé une feuille ESSAI en plaçant mes 97 prénoms et Noms en colonnes A et B.
J'ai prudemment recopié colA et ColB en colonnes témoin F et G pour une comparaison après fonctionnement de votre macro.
Puis je l'ai démarrer : les photos se placent parfaitement et rapidement en colonne A.
Toutefois mes colonnes A et B sont chamboulées...
Je vais voir ce que je peux faire pour conserver le contenu des colonnes A et colonnes B tel qu'il est.
Merci beaucoup Job75 : J'ai fait un pas en avant...
Webperegrino
 
Vote positif 0 Vote négatif
Webperegrino à dit:
J'ai créé une feuille ESSAI en plaçant mes 97 prénoms et Noms en colonnes A et B.
Cliquez pour agrandir...
Vous voulez dire en colonnes B et C, comme déjà dit c'est laborieux ! Et il y a le risque de fautes d'orthographe !

Voici la macro complétée pour remplir ces 2 colonnes après création des Shapes et les trier sur la colonne C (noms) :
VB: 
Sub PlacerPhotos()
Dim chemin$, fichier$, W#, s As Shape, n%
chemin = ThisWorkbook.Path & "\TROMBINOSCOPE\"
fichier = Dir(chemin & "*.jpg") '1er fichier du dossier
Application.ScreenUpdating = False
With ActiveSheet
    .Columns(1).ColumnWidth = 12 'largeur de colonne A à adapter
    W = .Columns(1).Width 'largeur en points
    For Each s In .Shapes
        If Not Intersect(s.TopLeftCell, .Columns(1)) Is Nothing Then s.Delete 'RAZ
    Next s
    .Range("B3:C" & .Rows.Count).ClearContents 'RAZ
    While fichier <> ""
        n = n + 1
        Set s = .Shapes.AddPicture(chemin & fichier, msoFalse, msoTrue, 0, .Rows(n + 2).Top, 0, 0)
        s.LockAspectRatio = True
        s.Width = W 'la photo prend la largeur de la cellule
        .Rows(n + 2).RowHeight = W * s.Height / s.Width + 0.7 'la cellule prend la hauteur de la photo + marge
        s.Name = Left(fichier, Len(fichier) - 4) 'renomme la Shape
        .Cells(n + 2, 2) = Left(fichier, Len(fichier) - 4) 'prénom et nom en colonne B
        fichier = Dir 'fichier suivant
    Wend
    With .Range("B3:B" & n + 2)
        .TextToColumns .Cells(1), Space:=True 'commande Convertir
        .EntireRow.Sort .Columns(2), xlAscending, Header:=xlNo 'tri sur la colonne C (noms)
    End With
End With
End Sub
 
Vote positif 0 Vote négatif
Job75,
Merci pour votre proposition #9 que je découvre à l'instant et que je vais étudier patiemment.
Je sors à l'instant de recherches à partir de votre précédente en #4, et voici ce que j'ai trouvé comme parade, en utilisant les formules des colonnes I et J pour rapatrier le contenu de mes colonnes B et C de départ.
Je reconnais que c'est un peu tiré par les cheveux mais j'obtiens le résultat désiré.
Je suis certain que votre solution #9 est plus intelligemment construite. Je m'en vais l'étudier.
Merci Job75 pour votre précieuse aide.
Webperegrino
 

Pièces jointes

Vote positif 0 Vote négatif
Job75,
Impressionnant, la rapidité de mise en place avec votre dernière macro.
Une petite erreur que je dois toutefois corriger pour l'arrivée des données en colonnes B qui peut s'éclater vers la colonne D à E.

Par exemple avec une photo.jpg au nom de "Jean-Michel·LB LE BRUN", je désire :
en colonne B : Jean-Michel·LB
en colonne C : LE BRUN

... et non pas comme avec votre dernière macro
en colonne B : Jean-Michel·LB
en colonne C : LE
en colonne D : BRUN

Je regarde si je peux trouver moi-m^me la correction,
Encore merci Job75, c'est génial.

(J'ai mis Jean-Michel·LB car j'ai un autre Jean-Michel dans la liste que je dois aussi différencier de la sorte en ajoutant Alt 0183 + l'initiale ou les initilas du nom)
Webperegrino
 
Vote positif 0 Vote négatif
Bonjour à toutes & à tous, bonjour @job75 , @Webperegrino

Je propose cette solution qui lit les noms des photos dans le répertoire source, les noms et prénoms dans la feuille cible et place les photos correspondantes, si elles existent, sur la feuille.
Petite précaution, elle supprime les photos déjà placées dans la plage cible si il y en a.
VB: 
Sub Trombino()
     Dim FSO As Object, DC As Object
    
' Si early binding :
'     Dim FSO As Scripting.FileSystemObject
'     Dim DC As Scripting.Dictionary
     Dim Wsh As Worksheet, RépTrombi As String, DébNoms As Range, DébPhotos As Range, Shp As Shape, Cible As Range, W As Double, Col, LMax, Tb
    
     RépTrombi = ThisWorkbook.Path & "\TROMBINOSCOPE"
    
     Set Wsh = Feuil1
     Set DébNoms = Wsh.[B1]   'première cellule contenant les noms
     Set DébPhotos = Wsh.[A1] 'première cellule contenant les photos
     W = DébPhotos.Width      'Largeur en point des cellules cible
    
     Set FSO = CreateObject("Scripting.FileSystemObject")
     Set DC = CreateObject("Scripting.Dictionary")
' Si early binding :
'     Set FSO = New Scripting.FileSystemObject
'     Set DC = New Scripting.Dictionary
    
     With Wsh
          Tb = .Range(DébNoms, .Cells(.Cells(.Rows.Count, DébNoms.Column).End(xlUp).Row, 2)).Resize(, 2)
     End With
    
     'Effacer les Photos précédentes si elles existent
     Col = DébPhotos.Column
     LMax = UBound(Tb, 1)
     For Each Shp In Feuil1.Shapes
          If Shp.Type = msoPicture And Shp.TopLeftCell.Column = Col And Shp.TopLeftCell.Row <= LMax Then
               Shp.Delete
          End If
     Next
    
     Set Photos = FSO.GetFolder(RépTrombi).Files
     For Each Photo In Photos
          If UCase(Photo.Name) Like "*.JPG" Then
               DC(UCase(Photo.Name)) = Photo.Path
          End If
     Next
    
     For i = 1 To LMax
          Set Cible = DébPhotos.Offset(i - 1)
          Clef = UCase(Tb(i, 1)) & " " & UCase(Tb(i, 2)) & ".JPG"
          If DC.Exists(Clef) Then
               Set s = Wsh.Shapes.AddPicture(DC(Clef), msoFalse, msoTrue, 0, Cible.Top, 0, 0)
               s.LockAspectRatio = True
               s.Width = W  'la photo prend la largeur de la cellule cible
               Cible.EntireRow.RowHeight = W * s.Height / s.Width + 0.7 'la cellule prend la hauteur de la photo + marge
          End If
     Next

End Sub
À bientôt
 

Pièces jointes

Vote positif 0 Vote négatif
Le Forum,
Bonjour AtTheOne,
Merci pour votre proposition : je vais l'étudier après mon repas.
JOB75 est tout près, aussi, de La solution, mais sa macro doit me préserver les colonnes C et suivantes.
Mes colonnes A et B contiennet déjà les Prénoms et noms de ceux qu'on recherche dans les .jpg de TROMBINOSCOPE.
Ces deux colonnes A et B ne devraient donc pas être touchées.
Quant aux colonnes C,D, E et suivantes, elles sont déjà occupées et ne doivent pas être perturbées par les lignes VBA en étude.
Webperegrino
 
Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD
Retour