Générer un graphe + gabarit, et lisser ce graphe sous excel, le copier dans word sous son titre.

Soyez le premier à donner votre avis sur cette source.

Snippet vu 15 241 fois - Téléchargée 28 fois

Contenu du snippet

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

A voir également

Ajouter un commentaire

Commentaire

Messages postés
129
Date d'inscription
mercredi 24 septembre 2003
Statut
Membre
Dernière intervention
12 février 2009

Salut,
Si tu mettais la feuille excel avec le tableau de valeur ce serait super pour la compréhension du travail...
Merci d'avance

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.