Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim P As Range, c As Range, chemin$, doc$, Wapp As Object, x$
If Target.Row < 8 Then Exit Sub
Cancel = True
Set P = Intersect(Target.EntireRow, [B:B,E:E,I:I,L:M,O:P])
Set c = P.Find("", P(1, 15), xlValues)
If Not c Is Nothing Then MsgBox "Toutes les cellules jaunes doivent être renseignées": c.Select: Exit Sub
If Not IsDate(P(1)) Then MsgBox "Date incorrecte": P(1).Select: Exit Sub
If Not IsNumeric(P(1, 8)) Then MsgBox "Heure incorrecte": P(1, 8).Select: Exit Sub
chemin = ThisWorkbook.Path & "\" 'à adapter
doc = "Modèle protocole.docx" 'à adapter
On Error Resume Next
Set Wapp = GetObject(, "Word.Application")
If Wapp Is Nothing Then Set Wapp = CreateObject("Word.Application")
Wapp.Visible = True
With Wapp.documents.Open(chemin & doc)
.Bookmarks("Date").Range = P(1).Text
.Bookmarks("Société").Range = P(1, 4)
.Bookmarks("Heure").Range = P(1, 8).Text
.Bookmarks("Code").Range = P(1, 11)
.Bookmarks("Nature").Range = P(1, 12)
.Bookmarks("Type").Range = P(1, 14)
.Bookmarks("Conditionnement").Range = P(1, 15)
x = P(1, 4) & Format(CDate(P(1)) + CDbl(P(1, 8)), " yyyy-mm-dd hhmmss") & ".docx"
Wapp.documents(x).Close False 'si le document Word est ouvert on le ferme
.SaveAs chemin & x
If Wapp.documents.Count = 1 Then Wapp.Quit Else .Close False
MsgBox "Le document '" & x & "' a été créé...", , "Word"
End With
End Sub