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
Job75,
Mon fichier réel contient bien en colonne B le prénom et en colonne C le Nom complet, que je dois conserver.
Exemple :
- avec en colonne B : "Prénom·Initiale Nom" s'il y a d'autres prénoms identiques, sinon Prénom simple (c'est déjà en place)
. exemple puis Henri·LB puis Henri·T, dans la liste Colonne B déjà prête et ne devant pas changer pendant le fonctionnement de la macro
. pareil pour la colonne C : sur la ligne des deux "Henri"
. on a LE BRUN pour le premier (pour le prénom Henri·LB),
. puis TABERNACLE (pour Henri·T)
Cette colonne C ne devant pas, non plus, changer pendant le fonctionnement de la macro

Mon souhait de départ : sur chaque ligne la macro compare donc la concaténation 'Prénom colonne B + " " + Nom colonne C' avec le nom des .jpg dans TROMBINOSCOPE pour placer en colonne A la photo correspondante, les colonnes B et C n'étant pas modifiées pendant le fonctionnement de la macro
Webperegrino
 
Vote positif 0 Vote négatif
Le Forum,
Job75,
AtTheOne,
AtTheOne, oui, je viens de voir, votre macro est parfaite : tout fonctionne.
Je suis heureux de voir que vos deux macro, Job75 et FatTheOne, sont extrêmement rapides.
Pour le moment j'ai une préférence pour celle de FatTheOne car les colonnes B et C ne sont pas touchés pendant le fonctionnement des codes Vba.
Youpi, ça fonctionne, Bravo à vous deux !
Je vais voir dans la macro de Job75 si aussi les colonnes B et C peuvent être préservées telles qu'elles sont remplies avant la mise en place des photos.
En tout cas merci à vous deux, et encore dommage que je sois obligé d'attribuer "LA SOLUTION en marquage vert de discussion" que sur le #12 en excluant malheureusement les lignes macro de Job75, dommage car Job75 a fait aussi une belle présentation.
Belle fin de journée,
Webperegrino

Nota : le fichier joint va servir aux autres, je l'ajoute ici pour info, en reconnaissance à JO75 et AtTheOne : les colonnes B et C ont été vidées car contenant des infos personnelles, vous devez en mettre d'autres avant d'activer les macros, bien sûr.
 

Pièces jointes

Vote positif 0 Vote négatif
Job75,
Je ne dois pas modier le contenu des colonnes B et C entre les lignes 3 et 161 parce que mon fichier réel contient dans cette feuille en colonnes B et C les prénoms et les noms déjà rapatriés d'une autre feuille Paramètres qui elle répertorie la liste de tous mes bénévoles inscrits.
C'est pour cela que je désire conserver les valeurs de la colonne B et C en cet état, avant d'aller placer en cellule A la photo correspondante.
Webperegrino
 
Vote positif 0 Vote négatif
Webperegrino à dit:
Je ne dois pas modier le contenu des colonnes B et C entre les lignes 3 et 161 parce que mon fichier réel contient dans cette feuille en colonnes B et C les prénoms et les noms déjà rapatriés d'une autre feuille Paramètres qui elle répertorie la liste de tous mes bénévoles inscrits.
C'est pour cela que je désire conserver les valeurs de la colonne B et C en cet état, avant d'aller placer en cellule A la photo correspondante.
Cliquez pour agrandir...
Bon d'accord alors finalement c'est plus simple, vous pouvez utiliser cette macro :
VB: 
Sub PlacerPhotos()
Dim chemin$, W#, s As Shape, lig&, fichier$
chemin = ThisWorkbook.Path & "\TROMBINOSCOPE\"
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
    For lig = 3 To .Cells(.Rows.Count, 3).End(xlUp).Row
        fichier = .Cells(lig, 2) & " " & .Cells(lig, 3) & ".jpg"
        If Dir(chemin & fichier) <> "" Then 'si le fichier existe dans le dossier
            Set s = .Shapes.AddPicture(chemin & fichier, msoFalse, msoTrue, 0, .Rows(lig).Top, 0, 0)
            s.LockAspectRatio = True
            s.Width = W 'la photo prend la largeur de la cellule
            .Rows(lig).RowHeight = W * s.Height / s.Width + 0.7 'la cellule prend la hauteur de la photo + marge
        End If
    Next lig
End With
End Sub
 
Vote positif 0 Vote négatif
Le Forum,
Merci, merci, merci Job75.
C'est parfait.
Et comme :
. la colonne A fait 16 de largeur,
. que mes photos vont occuper la largeur de la colonne...
... pour garder l'isomorphisme de base des photos .jpg placées dans le Trombinoscope, avec leurs hauteurs variant un peu, donc parfois différentes, peut-on garder l'isomorphisme en proposant aux lignes en colonne A de varier de hauteur en fonction de la hauteur de la photo JPG insérée.
Là, je pinaille peut-être un peu trop, mais c'est pour apprendre ; il y a peut-être une ligne vba qui permet de varier la hauteur des lignes en f(t) des photos... - lockRatio ou LockAspectRatio peut-être quelque chose comme cela - sachant que la dimension maitresse serait par exemple la largeur stable de la colonne A à 16 ?
Webperegrino
 
Vote positif 0 Vote négatif
Job75,
Excusez-moi.
En effet cette commande fait le travail dans vos propositions.
Pour votre proposition#23, que je viens d'appliquer, dans la zone A1, j'ai quelques boutons d'appel de macro... qui s'effacent à l'issue du fonctionnement de ces lignes vba. Cela se passe-t-il aussi chez vous ou c'est mon ordi qui fait des siennes ? J'y avais mis notamment le bouton de contrôle ActiveX commandant le départ de votre macro.
J'y vais avec des pincettes avec votre macro dans mon vrai et gros fichier : deux boutons de commande vba sont au-dessus de la cellule A et ils risquent de disparaître !
Sinon cette macro #22 fonctionne parfaitement.
Webperegrino
 
Vote positif 0 Vote négatif
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 = .Columns(1).Width 'largeur en points
    For Each s In .Shapes
        If s.Type = msoPicture Then If Not Intersect(s.TopLeftCell, .Columns(1)) Is Nothing Then s.Delete 'RAZ
    Next s
    For lig = 3 To .Cells(.Rows.Count, 3).End(xlUp).Row
        fichier = .Cells(lig, 2) & " " & .Cells(lig, 3) & ".jpg"
        If Dir(chemin & fichier) <> "" Then 'si le fichier existe dans le dossier
            Set s = .Shapes.AddPicture(chemin & fichier, msoFalse, msoTrue, 0, .Rows(lig).Top, 0, 0)
            s.LockAspectRatio = True
            s.Width = W 'la photo prend la largeur de la cellule
            .Rows(lig).RowHeight = W * s.Height / s.Width + 0.7 'la cellule prend la hauteur de la photo + marge
        End If
    Next lig
End With
End Sub
A+
 
Vote positif 0 Vote négatif
Solution
Le Forum,
Job75, bonjour,
Je viens d’appliquer, avec succès, vos lignes Vba.
J'ai même réussi à placer quelques lignes pour le tri des bénévoles par ordre croissant de prénoms.
Tout fonctionne maintenant parfaitement et il y a eu une sérieuse concurrence entre vous et AtTheOne.
Je reste épaté par le peu de lignes que vous créez pour réaliser cet objectif.
Ce critère place Job75 en première position, quoique je n'apprécie pas ce genre de classement.
En effet, AtTheOne a aussi réalisé un énorme travail qui fonctionne tout aussi bien, et je l'en félicite aussi.
Merci à vous deux, j'ai encore appris !
Bonne journée,
Webperegrino
 
Dernière édition:
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