Générer un graphe + gabarit, et lisser ce graphe sous Excel, le copier dans Word sous son titre. Ce code fonctionne dans n'importe quel cas, il suffira simplement de changer la programmation des colonnes dans la macro Excel. Le code est assez bien expliqué et je tiens à remercier les personnes de ce forum (en particulier Fanny) qui m'ont aidé à débugger ou à me débloqué quand j'avais des difficultés.
Source / Exemple :
Sub Macro1()
'*********************************************************************
'Auteur : Cédric BOURDONCLE
'Date : 23/06/04
'Description : Ce programme permet de lisser une courbe et de
' l'afficher avec son gabarit
'*********************************************************************
'Programme Principal
Creation_tableau
Lissage_courbe
Affich_courbe_lissee
Affich_gabarit
Copier_Coller_Word
End Sub
Sub Creation_tableau()
'********************************************************************
'Création d'une courbe à partir des éléments des colonnes A et B
'********************************************************************
Charts.Add
ActiveChart.ChartType = xlLineMarkers
ActiveChart.SetSourceData Source:=Sheets("Sheet1").Range("D13")
ActiveChart.SeriesCollection.NewSeries
ActiveChart.SeriesCollection(1).XValues = "=Sheet1!R1C1:R11C1"
ActiveChart.SeriesCollection(1).Values = "=Sheet1!R1C2:R11C2"
ActiveChart.SeriesCollection(1).Name = "=""Courbe non-lissée"""
ActiveChart.Location Where:=xlLocationAsObject, Name:="Sheet1"
ActiveChart.HasLegend = True
ActiveChart.Legend.Select
Selection.Position = xlRight
End Sub
Sub Lissage_courbe()
'********************************************************************
'Réalise un lissage de la courbe en faisant une moyenne
'********************************************************************
' Déclaration des variables
Dim monTab() As Double
Dim iCpt, i As Integer
' initialisation du pointeur
iCpt = 0
' Lecture de la feuille Excel tant que la valeur de la cellule B n'est pas nulle
Range("B1").Activate
While Not ActiveCell.Offset(1, 0).Value = ""
ReDim Preserve monTab(1, iCpt)
' Init pointeur à 1ere cellule
monTab(0, iCpt) = ActiveCell.Offset(0, -1).Value
' On somme la cellule1 de "B" avec la cellule2
monTab(1, iCpt) = (ActiveCell.Value + ActiveCell.Offset(1, 0).Value) / 2
' copie du résultat dans une autre colonne
ActiveCell.Offset(0, 2).Value = (ActiveCell.Value + ActiveCell.Offset(1, 0).Value) / 2
ActiveCell.Offset(1, 0).Activate 'incrémentation de l'offset cellule
iCpt = iCpt + 1 'incrémentation du pointeur cellule
Wend
End Sub
Sub Affich_courbe_lissee()
'*********************************************************************
'Affiche sur une nouveau graphe la courbe ainsi lissée
'*********************************************************************
' Affichage de la courbe lissée
Charts.Add
ActiveChart.ChartType = xlLine
ActiveChart.SetSourceData Source:=Sheets("Sheet1").Range("E18")
ActiveChart.SeriesCollection.NewSeries
ActiveChart.SeriesCollection(1).XValues = "=Sheet1!R1C1:R11C1"
ActiveChart.SeriesCollection(1).Values = "=Sheet1!R1C4:R11C4"
ActiveChart.SeriesCollection(1).Name = "=""courbe lissée"""
ActiveChart.Location Where:=xlLocationAsObject, Name:="Sheet1"
With ActiveChart
.HasTitle = True
.ChartTitle.Characters.Text = "courbe lissée"
.Axes(xlCategory, xlPrimary).HasTitle = False
.Axes(xlValue, xlPrimary).HasTitle = False
End With
End Sub
Sub Affich_gabarit()
'***********************************************************************
'Affiche sur le même graphe le gabarit
'***********************************************************************
' Déclaration de variables
Dim X As Variant
Dim Y As Variant
' Paramétrage de X et de Y
X = Array(-100, -30, -20, -11, -9, 0, 9, 11, 20, 30, 100)
Y = Array(-40, -40, -28, -20, 0, 0, 0, -20, -28, -40, -40)
' On ajoute le gabarit sur le graphique de la fonction lissée
ActiveChart.SeriesCollection.NewSeries
ActiveChart.SeriesCollection(2).XValues = X
ActiveChart.SeriesCollection(2).Values = Y
ActiveChart.SeriesCollection(2).Name = "=""Gabarit"""
ActiveChart.Location Where:=xlLocationAsObject, Name:="Sheet1"
With ActiveChart
.HasTitle = True
.ChartTitle.Characters.Text = "Courbe lissée + Gabarit"
.Axes(xlCategory, xlPrimary).HasTitle = False
.Axes(xlValue, xlPrimary).HasTitle = False
End With
End Sub
Sub Copier_Coller_Word()
'***********************************************************************
'Le graphique réalisé dans Excel sera importé dans Word
'***********************************************************************
' Déclaration des variables
Set AppWord = New Word.Application
Copy_Chart
Ouverture_Doc_Word
End Sub
Sub Copy_Chart()
'***********************************************************************
'Copie du graphe de Excel
'***********************************************************************
Worksheets("Sheet1").ChartObjects.Item(2).Activate
ActiveChart.ChartArea.Select
ActiveChart.ChartArea.Copy
End Sub
Sub Ouverture_Doc_Word()
'************************************************************************
'Ouverture d'un document Word
'Ecriture d'une phrase d'introduction
'Copie du graphe sous le titre
'Sauvegarde du fichier Word
'************************************************************************
'Déclaration des variables
Dim DocWord As Word.Document
Dim AppWord As Word.Application
Set AppWord = New Word.Application
Set DocWord = AppWord.Documents.Open("D:\Profiles\r58818\Desktop\Doc1.doc", ReadOnly:=False)
AppWord.ActiveWindow.Visible = True
DocWord.ActiveWindow.Selection.Font.Name = "Arial"
DocWord.ActiveWindow.Selection.TypeText Text:="Graphe numéro 1"
DocWord.ActiveWindow.Selection.TypeParagraph
DocWord.ActiveWindow.Selection.TypeParagraph
DocWord.Range.PasteSpecial (wdChartPicture)
DocWord.Shapes.Item(1).Select
AppWord.Selection.ShapeRange.IncrementTop 18#
DocWord.Application.ActiveDocument.Save
End Sub
Vous n'êtes pas encore membre ?
inscrivez-vous, c'est gratuit et ça prend moins d'une minute !
Les membres obtiennent plus de réponses que les utilisateurs anonymes.
Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.
Le fait d'être membre vous permet d'avoir des options supplémentaires.