Sub ListeVilles()
With Sheets("Feuil1")
cel = ActiveCell.Address
.Range("D:D").ClearContents
lg = 2
For Each ctl In .Shapes
If ctl.Name Like "Check*" Then
If .Range(ctl.ControlFormat.LinkedCell).Value = True Then
ctl.Select
.Cells(lg, 4) = Selection.Characters.Text
lg = lg + 1
End If
End If
Next
.Cells(lg + 1, 4) = .Range("B10")
.Range(cel).Select
End With
Application.ScreenUpdating = True
End Sub