GÉNÉRER UN GRAPHE + GABARIT, ET LISSER CE GRAPHE SOUS EXCEL, LE COPIER DANS WORD SOUS SON TITRE.

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