[VBA] Copie d'une feuille (avec graphique)

Version imprimable

[Resolu][VBA] Copie d'une feuille (avec graphique)

Bonjour,
je dois vérifier que ceci est faisable techniquement :

J'ai 2 templates.
Je vais :
- prendre le résultat du template 1 et le copier dans une nouvelle feuille "toto"
- à la suite (dans "toto"), juste en dessous, copier le résultat du template 2 pour la france
- à la suite( dans "toto"), juste en dessous, copier le résultat du template 2 pour l'italie
- etc... je copie le template 2 n fois (dans "toto") (une boucle qui fait une instance du template pour n pays)

Je vais copier ces temlpates dans un nouveau fichier, une nouvelle feuille. Pour simplifier, j'ai basé mes tests sur la copie de n onglets dans le meme fichier Excel, sur le 1er onglet.
en me basant sur mes recherches sur le net, je suis arrivé à quelques essais :
Code:

1 2 3 4 5 6 Sub TestCopy() For i = 2 To Worksheets.Count Worksheets(i).Range("A1").CurrentRegion.Copy Destination:=ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) Next i End Sub
qui me copie très bien chaque feuille à la suite l'une de l'autre, dans la 1ere feuille, graphique compris.

Mais....
les graphiques copiés, pointent toujours vers la feuille data. Donc, si je la supprime, les graphiques n'afficheront plus du tout les bonnes choses.
Je veux pouvoir copier n fois les feuilles (avec graphiques), dans une nouvelle feuille, à la queue leu leu, que je pourrai transmettre à des utilisateurs telle quelle, sans d'onglet données. (je vais ouvrir un template, copier les graph, fermer le template, en ouvrir un nouveau, le copier, etc...)

donc, j'etais partie sur la piste suivante : Faire un Paste Special, avec la bonne option (sous forme d'objet Excel, pas de bitmap, car comme j'aurai 70 graphiques, cela ferait un fichier bien trop ennorme !). Donc j'ai trouvé ceci :
Code:

1 2 ActiveSheet.PasteSpecial Format:="Picture (Enhanced Metafile)", Link:=False, DisplayAsIcon:=False
mais, cette fois ci mon code ne fonctionne plus :
Code:

1 2 3 4 5 6 7 8 9 10 Sub TestCopy2() For i = 2 To Worksheets.Count Worksheets(i).Activate Range("A1").CurrentRegion.Copy Worksheets(1).Activate ActiveSheet.PasteSpecial Format:="Picture (Enhanced Metafile)", Link:=False, DisplayAsIcon:=False Next i End Sub
j'obtiens l'erreur suivante :

Citation:

PasteSpecial method of Worksheet class failed

je pensais etre sur la bonne voie....
n'étant pas super doué en VBA, si qqun pouvait m'aider à comprendre où est le problème....

Merci !

29/09/2005, 15h09
ed_dexia

pourtant, le 1er exemple de copie, me copie tout, graphiques y compris :roll:

j'ai fait une mise en page, dans mes templates, je désire tout conserver, la position de chaque graph etc...
29/09/2005, 15h30
ed_dexia

Merci :)

en effet, je vois ce que cela donne...
sauf que ca me fait perdre toute ma mise en page, ca me pose les graphs les uns sur les autres, au lieu d'obtenir un joli tableau de bord bien présenté.
29/09/2005, 15h37
ed_dexia

MesGraphes.Top (un chiffre à virgule genre 78.5)

MesGraphes.Left (idem)

ok
mais, pour le paste "où je veux", cela fonctionne comment ?
(désolé d'insister, mais vu mes competences en VBA ... :oops: )
29/09/2005, 16h18
ed_dexia

ca marche super bien !

je vais l'adapter à mon besoin et voir si ca fait bien ce que j'esperais :)

Milles merci
29/09/2005, 16h44
ed_dexia

il me reste à résoudre le pb de la copie, que je laissais puor la fin car je pense que c'est moins difficile.
mes feuilles, contiennent des cellules, du texte, les graphiques etc...

et, je définis la fin de ma feuille par un texte "END" à la ligne 49 par exemple.

Je dois donc copier, dans ma feuille 1, le contenu de la feuille 5, jusqu'à la ligne "END". Et ensuite je copierai les graphiques comme tu me l'as indiqué.

je dois :
parcourir toutes les lignes de la feuille 5
noter la ligne "49"
faire une selection de A1 à ?49
copier ceci dans la feuille 1 (sans que cela copie les graphiques)

tu penses que c'est la bonne démarche ?

EDIT :
(sachant que si dans la feuille 5 la ligne 19 a une hauteur différente de la hauteur de base, par exemple, la feuille 1 doit etre de meme)

vu que j'ai des lignes ou des colonnes potentiellement compètement vide, je ne pouvais pas utiliser CurrentRegion, sinon ca m'aurait facilité la tache evidement de l'utiliser.

j'ai donc fait un code qui récupère toutes les colonnes, jusqu'à la ligne "END" , pour copier la feuille et son style, et ensuite je copie les graphes sous forme d'image.
enfin, j'utilise la propriété AlternativeText pour vérifier que je n'ai pas déjà positionné l'image, avec une feuille précédente, auquel cas j'utilise tes conseils pour positionner l'image, mais à chaque copie d'une nouvelle feuille, je dois mettre tout ca en desous, donc, incrémenté de la dernière ligne copiée dans la feuille cible. Ce qui donne :

Code:

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
 
        Application.ScreenUpdating = False
        Dim haut()
        Dim Gauche()
        Dim MesGraphes As ChartObject
        Dim MesImg As Shape
        Dim currentLine As Integer
        currentLine = 0
        Dim currentTop As Integer
        currentTop = 0
        Dim i As Variant
 
        For w = 2 To Worksheets.Count
            i = Empty
            'Copy the cells
            Set c = Worksheets(w).Cells.Find(What:="END", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
            If IsEmpty(c) = False Then
 
                Worksheets(w).Range(Worksheets(w).Cells(1, 1), Worksheets(w).Cells(c.Row, 1)).EntireRow.Copy
                Worksheets(1).Cells(currentLine + 1, 1).PasteSpecial Paste:=xlPasteValues
                Worksheets(1).Cells(currentLine + 1, 1).PasteSpecial Paste:=xlPasteFormats
 
                'Copy the graphs
                For Each MesGraphes In Worksheets(w).ChartObjects
                    i = i + 1
                    ReDim Preserve haut(i)
                    ReDim Preserve Gauche(i)
                    haut(i) = MesGraphes.Top
                    Gauche(i) = MesGraphes.Left
                    MesGraphes.Copy
                    Worksheets(1).PasteSpecial Format:="Picture (Enhanced Metafile)", Link:=False, DisplayAsIcon:=False
                Next
 
                'Set the image at the same position as the graphs
                i = 0
                For Each MesImg In Worksheets(1).Shapes
                    If MesImg.AlternativeText <> "done" Then
                        i = i + 1
                        MesImg.Top = haut(i) + currentTop
                        MesImg.Left = Gauche(i)
                        MesImg.AlternativeText = "done"
                    End If
                Next
                currentLine = currentLine + c.Row
                currentTop = currentTop + Worksheets(w).Cells(c.Row + 1, 1).Top
 
            Else
                MsgBox ("Chaine END non trouvée")
            End If
 
        Next
        Worksheets(1).Cells.Replace What:="END", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
        Application.ScreenUpdating = True

en tout cas, j'y serai pas arrivée sans toi ouskel'n'or, je connais quasi rien en VBA, merci :)

--