Erreur d'execution 1004 (ActiveSheet.Paste)

Staple1600 à dit:

Re

Personnellement , je réduirais un peu le code en utilisant cette syntaxe.
NB: Par principe, pas besoin de mot de passe quand on est phase de test, non 😕
(surtout sur un fichier exemple ... )
Code VBA:
Sub Prez_Gen_1()
' Fiche N°001.
Dim adres, zones, i%, col&, lig&
adres = Array("A1", "C26", "B26")
zones = Array("Prez", "DAS", "Extr_Inssuf")
For i = 0 To UBound(adres)
If Not IsEmpty(Range(adres(i))) Then
lig = Range(zones(i)).Find(Range(adres(i)), LookAt:=xlWhole).Row
col = Range(zones(i)).Column + 1
For Each s In Sheets("Images").Shapes
If s.TopLeftCell.Address = Cells(lig, col).Address Then s.Copy
Next s
ActiveSheet.Paste
Selection.ShapeRange.Left = Range(adres(i)).Offset(, 0).Left + 0
Selection.ShapeRange.Top = Range(adres(i)).Top + 1
End If
Next i
'Faire selon la même logique pour les autres fiches
'-----------
' reste du code à modifier ... ou pas
End sub

Cliquez pour agrandir...

Sub Prez_Gen_1()
Dim i As Object 'déclare la variable i (onglet Images)
Dim f As Object 'déclare la variable f (Fiche Selection))
Dim fs As Integer 'déclare la variable fs (FicheS)
Dim lig As Integer 'déclare la variable lig (LIGne)
Dim col As Integer 'déclare la variable col (COLonne)

'fiches N° 1 à 50
Application.ScreenUpdating = False 'masque les raffraîchissement d'écran
Set i = Sheets("Images") 'définit l'inglet i
Set f = Sheets("Fiche Selection")
For fs = 1 To 2450 Step 49 'boucles 1 : des lignes 1 à 2450 par pas de 49
If f.Cells(fs, 1).Value <> "" Then 'condition : si la cellule ligne fs, colonne 1 n'est pas vide
'puisque la plage nommée "Prez" est fixe et correspond à D22 pour ne pas écrire [Lig = 22] et [col = 5] ?
lig = Range("Prez").Find(f.Cells(fs, 1), LookAt:=xlWhole).Row 'définit la ligne lig
col = Range("Prez").Column + 1 'définit la colonne col
'puisque la plage nommée "Prez" est fixe et correspond à D22 pour ne pas écrire [Lig = 22] et [col = 5] ?
For Each s In Sheets("Images").Shapes 'boucle 2 : sur tous les objets "Shape" s de l'onglet "Images"
'si l'objet s se trouve dans la cellule en ligne li, colonne col, copie l'image et sort de la boucle
If s.TopLeftCell.Address = i.Cells(lig, col).Address Then s.Copy: Exit For
Next s 'prochain objet shape de la boucle 2
f.Paste 'copie l'objet s dans l'onglet "Fiche Selection"
'positionne l'objet s
Selection.ShapeRange.Left = f.Cells(fs, 1).Offset(, 0).Left + 0 'à gauche
Selection.ShapeRange.Top = f.Cells(fs, 1).Top + 1 'en haut
End If 'fin de la condition
'commentaires idem pour les cellules en colonne C puis B
If f.Cells(fs + 25, 3).Value <> "" Then
lig = Range("DAS").Find(f.Cells(fs + 25, 3).Value, LookAt:=xlWhole).Row
col = Range("DAS").Column + 1
For Each s In Sheets("Images").Shapes
If s.TopLeftCell.Address = i.Cells(lig, col).Address Then s.Copy: Exit For
Next s
f.Paste
Selection.ShapeRange.Left = f.Cells(fs + 25, 3).Offset(, 0).Left + 10
Selection.ShapeRange.Top = f.Cells(fs + 25, 3).Top + 5
End If

If f.Cells(fs + 25, 2).Value <> "" Then
lig = Range("Extr_Inssuf").Find(f.Cells(fs + 25, 2).Value, LookAt:=xlWhole).Row
col = [Extr_Inssuf].Column + 1
For Each s In Sheets("Images").Shapes
If s.TopLeftCell.Address = i.Cells(lig, col).Address Then s.Copy: Exit For
Next s
f.Paste
Selection.ShapeRange.Left = f.Cells(fs + 25, 2).Offset(, 0).Left + 1
Selection.ShapeRange.Top = f.Cells(fs + 25, 2).Top + 20
End If
Next fs
Application.ScreenUpdating = True
End Sub

Cliquez pour agrandir...