Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [C2:D2]) Is Nothing Or [C2] = "" Or [D2] = "" Then Exit Sub
Dim doc$, titre$, co As ChartObject, Wapp As Object, Wd As Object
doc = ThisWorkbook.Path & "\Document Word.docx" 'chemin d'accès et nom du document Word
If Dir(doc) = "" Then MsgBox "'" & doc & "' introuvable !", vbExclamation: Exit Sub
titre = LCase([C2] & " " & [D2]) & "*"
For Each co In ChartObjects
If LCase(co.Chart.ChartTitle.Text) Like titre Then
co.Copy 'copie
On Error Resume Next
Set Wapp = GetObject(, "Word.Application")
If Wapp Is Nothing Then Set Wapp = CreateObject("Word.Application")
On Error GoTo 0
Wapp.Visible = True
Set Wd = Wapp.Documents.Open(doc) 'ouvre le document Word
With Wd.ActiveWindow.Selection
.EndOf 6, 0 'Unit:=wdStory, Extend:=wdMove
.Paste 'colle
End With
[A1].Copy [A1] 'vide le presse_papiers
Wd.ActiveWindow.WindowState = 1 'wdWindowStateMaximize
AppActivate "Word"
Exit Sub
End If
Next
MsgBox "Le graphique correspondant n'existe pas !", vbExclamation
End Sub