Macro qui fontionne en pas a pas, mais pas en automatique

**guigol** · 28/01/2019, 20h45

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

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
 
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

**Patrice740** · 28/01/2019, 23h26

Re,

S'il s'agit de copier toutes les formes et de les coller décalées de 61 lignes vers le bas :

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
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

Edit : pour tout copier en A62 :

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
Option Explicit
Sub CopieObjets()
Dim wbS As Workbook, wbF As Workbook
Dim shS As Shape, shF As Shape
  Set wbS = ThisWorkbook 'Workbooks.Open("d:\fichiersource.xlsx")
  Set wbF = Workbooks.Add(1)
  For Each shS In wbS.Worksheets(1).Shapes
    shS.Copy
    wbF.Worksheets(1).Paste
    Set shF = wbF.Worksheets(1).Shapes(shS.Name)
    shF.Top = wbF.Worksheets(1).Range("A62").Top
    shF.Left = wbF.Worksheets(1).Range("A62").Left
  Next shS
'  wbF.Worksheets(1).Range("A1").Activate
End Sub

**guigol** · 29/01/2019, 16h41

Merci .

Les deux codes que tu as indiqué colle bien les objets evrs le nouveau fichier.
Hors dans certains cas, ils se retrouvent mélangés.

comme objet, j'ai des photos avec des flèches dessinées dessus, afin de pointer un élément de la photo.

hors lorsque le tout est copié vers le fichier destination, les flèches se retrouvent parfois en dehors de la photo

**Patrice740** · 31/01/2019, 00h17

Bonjour,

Voici un exemple que fonctionnent avec les 4 fichiers sources envoyés en MP :
Guigol.xlsm

et le code

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
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
Option Explicit
Sub CopieObjets()
'Const zone1$ = "A44:L63", dest1$ = "A62:L79"    'source théorique si pas de chevauchement
'Const zone2$ = "M44:X63", dest2$ = "M62:X79"
Const zone1$ = "A44:K63", dest1$ = "A62:L79"    'source volontairement réduite pour pallier à un chevauchement
Const zone2$ = "L44:X63", dest2$ = "M62:X79"    'source volontairement agrandie pour pallier à un chevauchement
Const zone3$ = "A66:K87", dest3$ = "A82:L99"
Const zone4$ = "L66:X87", dest4$ = "M82:X99"
Const zone5$ = "A107:K128", dest5$ = "A102:L119"
Const zone6$ = "L107:X128", dest6$ = "M102:X119"
Dim wbk As Workbook, wbkS As Workbook, wbkF As Workbook
Dim shp As Shape
  ' Définition des fichiers avec uniquement les 2 fichiers ouverts + cette macro
  For Each wbk In Workbooks
    If wbk.Name <> ThisWorkbook.Name Then
      If wbk.Name Like "FicheAppui*" Then
        Set wbkF = wbk
      Else
        Set wbkS = wbk
      End If
    End If
  Next
  If wbkS Is Nothing Or wbkF Is Nothing Then
    MsgBox "Il faut ouvrir les deux fichiers source et final" & vbCrLf & _
           "avant de lancer cette macro", vbCritical
    Exit Sub
  End If
  ' Effacer toutes les formes du fichier final, sauf commentaires et zones de texte
  If wbkF.Worksheets(1).Shapes.Count > 0 Then
    For Each shp In wbkF.Worksheets(1).Shapes
      Select Case shp.Type
        Case msoComment, msoTextBox
        Case Else
          shp.Delete
      End Select
    Next shp
  End If
  ' Copier les formes
  Application.ScreenUpdating = False
  With wbkS.Worksheets(1)
    Call CopierFormesZone(.Shapes, .Range(zone1), wbkF.Worksheets(1).Range(dest1))
    Call CopierFormesZone(.Shapes, .Range(zone2), wbkF.Worksheets(1).Range(dest2))
    Call CopierFormesZone(.Shapes, .Range(zone3), wbkF.Worksheets(1).Range(dest3))
    Call CopierFormesZone(.Shapes, .Range(zone4), wbkF.Worksheets(1).Range(dest4))
    Call CopierFormesZone(.Shapes, .Range(zone5), wbkF.Worksheets(1).Range(dest5))
    Call CopierFormesZone(.Shapes, .Range(zone6), wbkF.Worksheets(1).Range(dest6))
  End With
  Application.ScreenUpdating = True
  ' Voir le résultat
  Application.Goto wbkF.Worksheets(1).Range(dest1).Cells(1, 1)
  ActiveWindow.ScrollColumn = wbkF.Worksheets(1).Range(dest1).Column
  ActiveWindow.ScrollRow = wbkF.Worksheets(1).Range(dest1).Row - 1
End Sub
 
Private Sub CopierFormesZone(formes As Shapes, zone As Range, cible As Range)
Const nomT$ = "Transfert_Forme", nomA$ = "Ajout_Forme"
Dim forme As Shape, groupe As Shape
Dim coefH As Double, coefW As Double
Dim t() As String, i As Integer
  ' Chercher les formes situées dans la zone
  For Each forme In formes
    Select Case forme.Type
      Case msoComment, msoTextBox
      Case Else
        If Not Intersect(forme.TopLeftCell, zone) Is Nothing Then
          i = i + 1
          ReDim Preserve t(1 To i)
          t(i) = forme.Name
        End If
    End Select
  Next
  If i = 0 Then Exit Sub
  ' Définir le groupe des formes
  If i = 1 Then
    ' si il n'y a qu'une forme, en ajouter une pour créer un groupe à l'échelle 100%
    With formes(t(1))
      Set forme = formes.AddShape(msoShapeRectangle, .Left, .Top, .Width, .Height)
      forme.Name = nomA
      i = i + 1
      ReDim Preserve t(1 To i)
      t(i) = forme.Name
    End With
  End If
  Set groupe = formes.Range(t).Group
  ' Copier le groupe
  groupe.Name = nomT
  groupe.Copy
  cible.Parent.Paste
  groupe.Ungroup
  If t(2) = nomA Then formes(nomA).Delete
  Set forme = cible.Parent.Shapes(nomT)
  ' Positionner et redimensionner le groupe
  forme.Top = cible.Top + 2
  forme.Left = cible.Left + 2
  coefH = (cible.Height - 4) / forme.Height
  coefW = (cible.Width - 4) / forme.Width
  If coefH < 1 Or coefW < 1 Then
    forme.Height = forme.Height * IIf(coefH < coefW, coefH, coefW)
    forme.Width = forme.Width * IIf(coefH < coefW, coefH, coefW)
  End If
  forme.Ungroup
  If t(2) = nomA Then cible.Parent.Shapes(nomA).Delete
End Sub

Macro qui fontionne en pas a pas, mais pas en automatique

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager