code qui fonctionne en pas a pas. mais pas en automatique Résolu

Question

Bonsoir

Ci-dessous, mon code.
Lorsque je le fais tourner en pas à pas (F8), il fonctionne sans problème.
Il sélectionne tous les objets de mon fichiersource et les copie dans le fichier créé au bon emplacement.

Lorsque je le lance avec F5, toutes les opérations semblent fonctionner (ouverture, fichier, créattion fichier, selection des objets) sauf la dernière : la copie des objets dans le nouveau fichier.

une idée?

Par avance, merci

Sub CopieObjets()
            'ouvre le classeur...
            Workbooks.Open ("d:\fichiersource.xlsx")
            Nom_Fichier_Source = ActiveWorkbook.Name
            Workbooks.Add (1)
            Nom_Fichier_Final = ActiveWorkbook.Name
            
            Workbooks(Nom_Fichier_Source).Sheets(1).DrawingObjects.Select
            Selection.Copy
            Workbooks(Nom_Fichier_Final).Activate
            Range("A62").Select
            Workbooks(Nom_Fichier_Final).Sheets(1).Paste

End Sub

        EDIT : Ajout des balises de code (la coloration syntaxique).
Explications disponibles ici : ICI 

Merci d'y penser dans tes prochains messages.

Patrice33740 · Answer

Bonjour,

S'il s'agit de copier toutes les formes et de les coller décalées de 61 lignes vers le bas :
Option Explicit
Sub CopieObjets()
Dim wbS As Workbook, wbF As Workbook
Dim shS As Shape, shF As Shape
Dim dT, dL
  Set wbS = Workbooks.Open("d:\fichiersource.xlsx")
  Set wbF = Workbooks.Add(1)
  dT = wbF.Worksheets(1).Range("A62").Top - wbS.Worksheets(1).Range("A1").Top
  dL = wbF.Worksheets(1).Range("A62").Left - wbS.Worksheets(1).Range("A1").Left
  For Each shS In wbS.Worksheets(1).Shapes
    shS.Copy
    wbF.Worksheets(1).Paste
    Set shF = wbF.Worksheets(1).Shapes(shS.Name)
    shF.Top = shS.Top + dT
    shF.Left = shS.Left + dL
  Next shS
'  wbF.Worksheets(1).Range("A1").Activate
End Sub

Patrice33740 · Answer

RE,

Dans ce cas :
Option Explicit
Sub CopieObjets()
Const adr$ = "A62"
Dim wbS As Workbook, wbF As Workbook
Dim shS As Shape, shF As Shape
Dim dT, dL
  Set wbS = Workbooks.Open("d:\fichiersource.xlsx")
  ' Chercher l'emplacement de la première forme
  If wbS.Worksheets(1).Shapes.Count > 0 Then
    dT = wbS.Worksheets(1).Shapes(1).Top
    dL = wbS.Worksheets(1).Shapes(1).Left
  End If
  ' Chercher le coin supérieur gauche de l'ensemble des formes
  For Each shS In wbS.Worksheets(1).Shapes
    If shS.Top < dT Then dT = shS.Top
    If shS.Left < dL Then dL = shS.Left
  Next shS
  Set wbF = Workbooks.Add(1)
  ' Copier les formes
  With wbF.Worksheets(1)
    For Each shS In wbS.Worksheets(1).Shapes
      shS.Copy
      .Paste
      Set shF = .Shapes(shS.Name)
      shF.Top = shS.Top - dT + .Range(adr).Top
      shF.Left = shS.Left - dL + .Range(adr).Left
    Next shS
  End With
  Application.Goto wbF.Worksheets(1).Range(adr)
  ActiveWindow.ScrollColumn = wbF.Worksheets(1).Range(adr).Column
  ActiveWindow.ScrollRow = wbF.Worksheets(1).Range(adr).Row
End Sub

Patrice33740 · Answer

Bonjour,

Au vu des fichiers que tu as transmis en MP, cela n'est pas aussi simple :
1) il y a 6 zones sources différentes et donc 6 zones destinations 
2) les zones destinations sont plus petites que les zones sources, faut-il redimensionner les formes ?
3) les fichiers destinations contiennent déjà des formes résiduelles, faut-il les supprimer ?

Patrice33740 · Answer

Bonjour,

Voici un exemple que fonctionnent avec les 4 fichiers sources envoyés en MP :
 https://mon-partage.fr/f/lSCqj0bu/

Code qui fonctionne en pas a pas. mais pas en automatique

4 réponses

Votre réponse