Bonjour,
il faut que les cases soit placées à l'intérieur des cellules sans qu'elles ne touchent au lignes,
Sub CréerCaseàcocher()
Dim Nom As String, LastRw As Long, i As Long
Dim l As Double, t As Double, w As Double, h As Double
Dim Caseàcocher As Object
LastRw = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
EffaceCaseàcocher
For i = 2 To 20 'ou 'LastRw
With Cells(i, 1) 'colonne A
l = .Left + 2
t = .Top + 1
w = .Width - 2
h = .Height - 2
End With
With ActiveSheet
Set Caseàcocher = .CheckBoxes.Add(l, t, w, h)
With Caseàcocher
.Characters.Text = ""
.OnAction = "Caseàcocher_Cliquer"
.Placement = xlMove
End With
End With
Next
End Sub
Sub EffaceCaseàcocher()
For Each shp In ActiveSheet.Shapes
If Left(shp.Name, 9) = "Check Box" Then shp.Delete
Next
End Sub
Sub Caseàcocher_Cliquer()
Nom = Application.Caller
rw = ActiveSheet.Shapes(Nom).TopLeftCell.Row
col = ActiveSheet.Shapes(Nom).TopLeftCell.Row
MsgBox Nom & " cellule (" & Cells(rw, col).Address & ")"
End Sub