XL 2013 déplacer beaucoup de photos vers un emplacement précis

[Usine à gaz]

Bonjour à toutes et à tous,

Je butte sur un nouveau problème et malgré mes recherches et tentatives, je n'y arrive pas.

J'ai dans un fichier beaucoup de photos importées de 300 à 5000 voire plus.
Ces photos ne sont pas placées les unes au-dessous des autres. Il y a 8 à 10 lignes en chaque photos
Dans le fichier exemple joint, elles sont dans l'onglet Photos.

Dans mon onglet "destination", dans la colonne B, j'ai des noms sur les lignes qui se suivent.
Les photos de l'onglet "photos" sont dans le même ordre que les noms de la feuille "destination".

Ma question
Est-il possible par macro de copier les photos de la feuille "photos" dans la feuille "destination" dans la colonne A à partir de la ligne 3, à la suite : 1 photo dans chaque cellule en descendant (comme montré dans la colonne C de la feuille "destination").

LOL, à l'appui de mes explications vaseuses (comme diront certains), je joins le fichier test qui contient 10 photos pour le test.

Si quelqu'un a une idée, ça m'arrangerait bien
Avec mes remerciements,
Je vous souhaite à toutes et à tous une belle fin de journée,
Amicalement,
arthour973

 

[Lone-wolf]

Re

@Staple1600 . Et bien, il suffit de mettre le bouton dans la feuille "Destination".

 

[Staple1600]

Re

Je disais juste cela par prudence.
Ta macro (telle que j'aurai pu l'écrire)

Sub test_LW_Bis()
Dim i&
Application.ScreenUpdating = False
With Feuil7
    For i = 1 To .Shapes.Count
    If .Shapes(i).Type = 13 Then
    .Shapes(i).Copy
    Feuil1.Cells(i + 2, 1).PasteSpecial
    End If
    Next i
End With
End Sub

 

[Usine à gaz]

Bonjour JM,
Bonjour Lone, Le Forum,

Vraiment super !!! le dernier code de JM (code Lone modifié) fonctionne le mieux car instantané ou presque à l'exécution.
Pour 3000 photos = 2/3 secondes chez moi.
@ JM : excel n'a pas l'air de trop souffrir LOL

Voilà qui prouve que rien ne remplace le travail d'équipe
Je joins le fichier,
Un grand merci à vous,
Bon WE,
Amicalement,
arthour973,

 

[Lone-wolf]

Bonjour Lionel

@arthour973

Pourquoi tu as mis ceci
Sheets("destination").Select
[a1].Select

Alors que tu pourrais faire comme ceci: Application.goto Feuil1.Range("a1")

 

[Usine à gaz]

Bonjour Lone,
Je voulais juste revenir sur ma feuille destination mais effectivement, ce n'est pas nécessaire

 

[Lone-wolf]

Re Lionel

@arthour973 c'était juste un exemple.

 

[Usine à gaz]

OUI, mais une très bonne remarque

 

[Staple1600]

Bonjour le fil, le forum

@arthour973
Tu nous indiquer "le poids" en Ko de ton fichier avec 5000 photos et plus ?

 

[Usine à gaz]

Bjr JM,

taille : 11.0 Mo (11 583 204 octets) pour 3000 photos

 

[Staple1600]

Re

@arthour973
Si on suit ta logique, c'est 6000 photos, puisque qu'on copie les images de la feuille A vers la feuille B.
A moins que ce ne soit 1500 sur la feuille A, ce qui fera donc aprés recopie 3000.

 

[Usine à gaz]

Effectivement, tu as raison, c'est bien 6000 photos puisque je conserve l'origine "feuille photos"

 

[Lone-wolf]

Re

@arthour973

De quel format sont les images d'origines? Si .jpg ou et bmp tu peux réduire leurs poids en réduisant leurs tailles et les transformer en .gif .
Il y a "photofiltre studio" logiciel gratuit pour le faire.

 

[Staple1600]

Re,

@arthour973
Je viens de relire le titre de ton fil
Puisqu'on copie, il ne s'agit pas de déplacement
Apparemment mieux vaut copier que déplacer
Essaie le déplacement avec ceci, tu auras une surprise

Sub test_LW_Ter()
Dim i&
Application.ScreenUpdating = False
With Feuil7
    For i = 1 To .Shapes.Count
    .Shapes(i).Cut
    Feuil1.Cells(i + 2, 1).PasteSpecial
    Application.CutCopyMode = False
    Next i
End With
End Sub

 

[Staple1600]

Re

Ici le déplacement se fait sans qu'Excelne bronche

Sub test_LW_Ter()
Dim i&, sh As Shape
Application.ScreenUpdating = False
i = 2
For Each sh In Feuil7.Shapes
sh.Select: sh.Cut
Feuil1.Range("A" & i).PasteSpecial
i = i + 1
Application.CutCopyMode = False
Next
End Sub

 

[Staple1600]

Re,

@Lone-wolf

Re
@arthour973
tu peux réduire leurs poids en réduisant leurs tailles et les transformer en .gif .
Il y a "photofiltre studio" logiciel gratuit pour le faire.

Pas besoin, pour du basique, Excel a ce qu'il faut à la maison

Sub Excel_IMG_KoMpReSSoR()
CommandBars(28).FindControl(, 6382).Execute
End Sub

PS: test fait sur Excel 2003
Je te laisse trouver les équivalents pour les versions supérieures