copier coller feuille afec graph sans liaison par macro

Le
sleg
Bonjour,

j'ai un probleme avec cette macro sur la derniere partie FE4, c'est
une feuille avec des graphiques (25) et la macro me les copie avec la
liaison avec les données qui ne seront pas consultable donc j'aimerais
savoir s'il est possible de faire une copier coller juste image a la
place de ce que j'ai a l'heure actuelle.

merci de votre aide.


MAcro :
Sub Export01()
Dim Cl As Workbook
Dim Fe1 As Worksheet
Dim Fe2 As Worksheet
Dim Fe3 As Worksheet
Dim Fe4 As Worksheet
Set Fe1 = Worksheets("Chronos")
Set Fe2 = Worksheets("Fiche a valider")
Set Fe3 = Worksheets("Fiche a envoyer")
Set Fe4 = Worksheets("Graph Mois")

Application.ScreenUpdating = False
Set Cl = Workbooks.Add
With Cl
Application.DisplayAlerts = False
.SaveAs ("\serveurepertoire01Référentiels" & "" &
"Indispo_2010_V2r01" & ".xls")

Fe1.Copy .Worksheets("Feuil1")
ActiveSheet.Name = "Chronos"
Sheets("Chronos").Select
Cells.Select
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False


Fe2.Copy .Worksheets("Feuil2")
ActiveSheet.Name = "Fiche a valider"
Sheets("Fiche a valider").Select
Cells.Select
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False

Fe3.Copy .Worksheets("Feuil3")
ActiveSheet.Name = "Fiche a envoyer"
Sheets("Fiche a envoyer").Select
Cells.Select
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False

Fe4.Copy .Worksheets("Feuil3")
ActiveSheet.Name = "Graph Mois"
Sheets("Graph Mois").Select
Cells.Select
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False

Application.DisplayAlerts = False
.Worksheets("Feuil1").Delete
.Worksheets("Feuil2").Delete
.Worksheets("Feuil3").Delete
.Worksheets("Feuil4").Delete
Application.DisplayAlerts = True
.Save
.Close
End With
Application.ScreenUpdating = True
Set Fe1 = Nothing
Set Fe2 = Nothing
Set Fe3 = Nothing
Set Cl = Nothing
End Sub
Vidéos High-Tech et Jeu Vidéo
Téléchargements
Vos réponses
Gagnez chaque mois un abonnement Premium avec GNT : Inscrivez-vous !
Trier par : date / pertinence
isabelle
Le #20812841
bonjour sleg,

voici un exemple

'_______________________________________________________________________________
'Comment exporter plusieurs graphiques dans une même image gif
'auteur: SilkyRoad
'Cet exemple regroupe les 4 premiers graphiques incorporés de la feuille
active puis les exporte en un seule image gif.
'_______________________________________________________________________________
Private Const Fichier As String = "C:ImageTemp.gif"

Sub ExporteGIF_GroupeGraphiques()
Dim Sh As Shape
Dim Tableau(1 To 4) As String
'Sous Excel2000, indiquez:
'Dim Tableau(1 To 4) As Variant
Dim i As Integer, Nb As Integer

'Supprime l'image temporaire si elle existe
If Dir(Fichier) <> "" Then Kill Fichier

'Boucle sur les 4 premiers graphiques de la feuille active
For i = 1 To 4
Tableau(i) = ActiveSheet.ChartObjects(i).Name
Next

'Regroupe les graphiques
Set Sh = ActiveSheet.Shapes.Range(Tableau).Group

'copie la forme
Sh.CopyPicture
'crée un graphique
With ActiveSheet.ChartObjects.Add(0, 0, _
Sh.Width, Sh.Height).Chart
.Paste 'colle l'image dans graphique
' enregistre le graphique au format gif
.Export Fichier, "GIF"
End With

Nb = ActiveSheet.ChartObjects.Count
'supprime le graphique
ActiveSheet.ChartObjects(Nb).Delete

Sh.Ungroup
End Sub
'_______________________________________________________________________________

isabelle

sleg a écrit :
Bonjour,

j'ai un probleme avec cette macro sur la derniere partie FE4, c'est
une feuille avec des graphiques (25) et la macro me les copie avec la
liaison avec les données qui ne seront pas consultable donc j'aimerais
savoir s'il est possible de faire une copier coller juste image a la
place de ce que j'ai a l'heure actuelle.

merci de votre aide.


MAcro :
Sub Export01()
Dim Cl As Workbook
Dim Fe1 As Worksheet
Dim Fe2 As Worksheet
Dim Fe3 As Worksheet
Dim Fe4 As Worksheet
Set Fe1 = Worksheets("Chronos")
Set Fe2 = Worksheets("Fiche a valider")
Set Fe3 = Worksheets("Fiche a envoyer")
Set Fe4 = Worksheets("Graph Mois")

Application.ScreenUpdating = False
Set Cl = Workbooks.Add
With Cl
Application.DisplayAlerts = False
.SaveAs ("\serveurrepertoire01Référentiels" & "" &
"Indispo_2010_V2r01" & ".xls")

Fe1.Copy .Worksheets("Feuil1")
ActiveSheet.Name = "Chronos"
Sheets("Chronos").Select
Cells.Select
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:úlse, Transpose:úlse


Fe2.Copy .Worksheets("Feuil2")
ActiveSheet.Name = "Fiche a valider"
Sheets("Fiche a valider").Select
Cells.Select
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:úlse, Transpose:úlse

Fe3.Copy .Worksheets("Feuil3")
ActiveSheet.Name = "Fiche a envoyer"
Sheets("Fiche a envoyer").Select
Cells.Select
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:úlse, Transpose:úlse

Fe4.Copy .Worksheets("Feuil3")
ActiveSheet.Name = "Graph Mois"
Sheets("Graph Mois").Select
Cells.Select
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:úlse, Transpose:úlse

Application.DisplayAlerts = False
.Worksheets("Feuil1").Delete
.Worksheets("Feuil2").Delete
.Worksheets("Feuil3").Delete
.Worksheets("Feuil4").Delete
Application.DisplayAlerts = True
.Save
.Close
End With
Application.ScreenUpdating = True
Set Fe1 = Nothing
Set Fe2 = Nothing
Set Fe3 = Nothing
Set Cl = Nothing
End Sub





Publicité
Poster une réponse
Anonyme