Option Explicit
'Pour cocher les cellules D2 à D1000
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
ActiveSheet.Unprotect Password:="."
On Error GoTo Fin: If Target.Count > 1 Then Exit Sub
Dim Chaine$, i&
If Not Intersect(Target, [D1:D1000]) Is Nothing Then
Application.ScreenUpdating = False
If Cells(Target.Row, "B") <> "" Then
If Target = "J" Then Target = "" Else Target = "J"
Cells(1 + Target.Row, "D").Select
End If
Chaine = ""
For i = 2 To [B65500].End(xlUp).Row
If Cells(i, "D") = "P" Then
Chaine = Chaine & "-" & Cells(i, "C") & Chr$(10)
End If
Next i
[F2] = Chaine
End If
Fin:
Application.ScreenUpdating = True
ActiveSheet.Protect Password:="."
End Sub