Discussion :

[retraite83]

Bonjour,

dans ma boucle de test, certaines image ne sont pas mise en page, la cellule reste blanche, soit la sélection et le "copy" par ActiveSheet.Shapes(shp.Name).Copy ne se font pas, soit "ActiveSheet.Paste" ne s'exécute pas. J'ai vérifié la boucle s'exécute bien jusqu'au bout mais il y a des manques d'image sur certaines lignes de façon aléatoire.

Je n'arrive pas à déterminer avec le pas à pas

Avez-vous eu ce problème ?
peut-on changer (de façon simple) la méthode pour copier/coller une image. j'ai vu beaucoup de choses mais complexe pour moi...

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
 
Sub test()
 
Dim Delta1 As Integer
Dim i1 As Integer
Dim s As Variant
Application.ScreenUpdating = False
Delta1 = 6
 
' Feuille des images
Set catalogue = Workbooks("Image.xlsm").Sheets("Image")
' Feuille contenant la mise en page
Set edition = Workbooks("Mise en page.xlsm").Sheets("Edition")
 
 
For i1 = 1 To 50
' Sélection de l'image
catalogue.Activate
Range("D" & i1).Select
     For Each shp In ActiveSheet.Shapes
        If shp.Top = catalogue.Range("D" & i1).Top Then
ActiveSheet.Shapes(shp.Name).Copy
' Positionnement sur la mise en page de l'édition
edition.Activate
'Delta1 = Delta1 + 5
Range("B" & Delta1 + 2).Select
' Copie de la nouvelle image
ActiveSheet.Paste
'Delta1 = Delta1 + 5
        End If
     Next
Delta1 = Delta1 + 5
Next i1
 
Application.ScreenUpdating = True
End Sub

[patricktoulon]

salut retraité
prend un fichier vierge ,met lui des images ou shapes en colonne"D" ou tu veux a partir de la ligne 1 jusqu'a la ligne 50 juste 2 ou 3 pour l'exemple

et lance ce code
l'explication est dans les commentaires

il te sera facile d'adapter ca sur deux classeurs
il ne te reste plus qu'a boucler sur les noms des copies pour les positionner (((((leur nom c'est l'adress de destination)))))

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
Sub test()
    Dim tabloimage()
    Delta = 8
    'on rassemble les images dans un tableau
    For Each shap In ActiveSheet.Shapes
        If shap.TopLeftCell.Row >= 1 And shap.TopLeftCell.Row <= 50 And shap.TopLeftCell.Column = 4 Then
            i = i + 1: ReDim Preserve tabloimage(1 To i): shap.Name = "B" & Delta: tabloimage(i) = shap.Name: Delta = Delta + 7
        End If
    Next
    'maintenant on va les grouper,copier,degrouper et coller la copie du groupe en colonne b a partir de la ligne 8
    ' on degroupe les image de la copie
    'elles devraient porter comme nom l'address des  cellules de destination selon delta  +2 +5 donc 7
    With ActiveSheet
        With .Shapes.Range(tabloimage): .Group.Copy: .Ungroup: End With
        .Cells(8, 2).Select
        .Paste
        .Shapes(.Shapes.Count).Ungroup
    End With
End Sub

voila en fait tu copie une seule fois mais toutes les shapes en meme temps
ce qui devrait limiter tes activate entre deux classeur
et je suis pratiquement sur que meme avec deux classeurs les activates ne sont pas necessaires a tester
fait moi plaisir teste et observe

[retraite83]

Merci Patrick,

j'ai intégré ton code et j'ai l'erreur :

"erreur d'exécution 1004 Erreur définie par l'application ou l'objet" sur la ligne :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
 
With .Shapes.Range(tabloimage)

Je pense que dans :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
 
For Each shap In ActiveSheet.Shapes
        If shap.TopLeftCell.Row >= 1 And shap.TopLeftCell.Row <= 5 And shap.TopLeftCell.Column = 4 Then
            i = i + 1: ReDim Preserve tabloimage(1 To i): shap.Name = "B" & Delta: tabloimage(i) = shap.Name: Delta = Delta + 7
        End If

il faut mettre

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
 
i = i + 1: ReDim Preserve tabloimage(1 To i): shap.Name = "B" & Delta: tabloimage(i) = shap.Name: Delta = Delta + 5

La première image est à mettre en B8, la seconde en B13, puis B18 et ainsi de suite


Autre point, dans une deuxième temps, après la mise au point je veux retailler les images, j'imagine quelque chose comme cela :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
 
        .ShapeRange.ScaleHeight 0.4693333333, msoFalse, msoScaleFromTopLeft

entre .Paste et .Shapes au niveau de :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
 
         .Paste
         .Shapes(.Shapes.Count).Ungroup

[patricktoulon]

re
bonjour
regarde tes variables local je peux pas deviner la raison

et avant tout testeavec 2 fichiers vierges avant de l'intégrer dans ton fichier

[retraite83]

Voilà le résultat en pièces jointes de mon test, fichier neuf, 3 images en D1, D2 et D3

la variable Delta = 23 n'est pas normale, cela correspond à la 4éme image (8,13,18,23) hors il n'y en a que 3, donc pas d'arrêt ?

le message est :
"L'élément portant ce nom est introuvable"

j'ai ajouté des activate dans le code sinon ça plantait dès le début

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
 
Sub test()
 
Dim Delta As Integer
Dim i As Integer
Dim tabloimage()
Application.ScreenUpdating = False
Delta = 8
 
' Feuille du classeur contenant les images
Set catalogue = Workbooks("Catalogue.xlsm").Sheets("test")
' Feuille du classeur contenant la mise en page
Set edition = Workbooks("mise en page.xlsm").Sheets("edition")
 
'on rassemble les images dans un tableau
catalogue.Activate
    For Each shap In ActiveSheet.Shapes
        If shap.TopLeftCell.Row >= 1 And shap.TopLeftCell.Row <= 3 And shap.TopLeftCell.Column = 4 Then
            i = i + 1: ReDim Preserve tabloimage(1 To i): shap.Name = "B" & Delta: tabloimage(i) = shap.Name: Delta = Delta + 5
        End If
    Next
    'maintenant on va les grouper,copier,degrouper et coller la copie du groupe en colonne b a partir de la ligne 8
    ' on degroupe les image de la copie
    'elles devraient porter comme nom l'address des  cellules de destination selon delta  +2 +5 donc 7
    edition.Activate
    With ActiveSheet
        With .Shapes.Range(tabloimage): .Group.Copy: .Ungroup: End With
        .Cells(8, 2).Select
        .Paste
        .Shapes(.Shapes.Count).Ungroup
    End With
 
Application.ScreenUpdating = True
End Sub

[patricktoulon]

donne moi ,tes deux fichiers neufs avec tes 3 images je regarderais tout a l'heure
pour le moment occupé en compta