Conserver la même checkbox sur toutes les lignes

S

siocnarf

XLDnaute Occasionnel
Bonjour,

Je suis à créer un classeur avec plusieurs checkbox sur une même ligne. J'associe des VBA à ces checkbox afin que des valeurs soient associés en fonction que la checkbox est coché ou pas.

Ma problématique est que chaque ligne correspond à un incident. Donc au fur et à mesure que de nouveaux incidents sont créés, je veux réutiliser les checkbox de la ligne précédent.

1. Comment aisément copier tous les checkbox d'une ligne sur la ligne du dessous?
2. Comment réutiliser les checkbox d'une ligne à l'autre?
3. Y-a-t-il une manière de décocher tous les checkbox d'un classeur d'un coup?

Code: 
Private Sub CheckBox1_Click()
With ActiveSheet.Shapes("Checkbox1").TopLeftCell
    nligne = .Row
    ncolonne = .Column
    sAddresse = .Address
End With
'Valeur de la réponse quand la case est cochée
nvaleur = 20
'Colonne à côté signifie +1 ou 1
nemplacementvaleur = 1
Call setvaleur(nligne, ncolonne, nvaleur, nemplacementvaleur)
End Sub

Private Sub setvaleur(S_nligne, S_ncolonne, S_nvaleur, S_nemplacementvaleur)
S_celloutput = Cells(S_nligne, S_ncolonne + S_nemplacementvaleur).Address
'(RowAbsolute:=False, ColumnAbsolute:=False)
If CheckBox1.Value = True Then Range(S_celloutput).Value = S_nvaleur
If CheckBox1.Value = False Then Range("C4").Value = 0
End Sub

En pièce jointe un exemple de fichier avec les cases à cocher.

Merci pour votre aide,

François Racine
 

Pièces jointes

  • test.xls
    62.5 KB · Affichages: 78
  • test.xls
    62.5 KB · Affichages: 271
  • test.xls
    62.5 KB · Affichages: 86
Trier par date Trier par votes
mapomme

mapomme

XLDnaute Barbatruc
Supporter XLD
Re : Conserver la même checkbox sur toutes les lignes

Bonsoir siocnarf,

Je préfère utiliser à la place des checkbox des caractères de remplacement affublés de la police WingDings. Le caractère de code 111 représente une case non cochée et le caractère de code 254 représente une case cochée.

Pour cocher/décocher une case, on utilise le double-clique sur la cellule (qu'on pourrait remplacer par le clique droit)

Le code pour cocher/décocher une case se trouve dans le module de code de la feuille "Feuil1". Il permet de cocher ou décocher une case ainsi que d'entreprendre les actions induites.

Le module "Module2" comporte une procédure ajouter_incident qui permet d'ajouter un incident. Cette procédure est déclenchée quand on clique sur le bouton "insérer Incident" sur la feuille "Feuil1".

Le code dans le module de "Feuil1":
VB: 
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

If Target.Font.Name = "Wingdings" Then
  'on passe de coché à décoché et vice-versa
  Target = IIf(Target = Chr(PasCoche), Chr(Coche), Chr(PasCoche))
  Cancel = True
  Select Case Target.Column
    ' si colonne B
    Case Range("B1").Column
      Target.Offset(0, 1) = IIf(Target = Chr(Coche), 20, "")
    ' si colonne D
    Case Range("D1").Column
       If Target = Chr(Coche) Then MsgBox ("Aller porter plainte")
    ' si colonne E
    Case Range("E1").Column
      Target.Offset(0, 1) = IIf(Target = Chr(Coche), "Pas bien", "")
    ' si colonne G
    Case Range("G1").Column
      Target.Offset(0, 1) = IIf(Target = Chr(Coche), "tête de linotte", "")
  End Select
End If

End Sub

Le code d'insertion d'un incident dans module2:
VB: 
Option Explicit

Public Const PasCoche = 111
Public Const Coche = 254

Sub ajouter_incident()
Dim xrg As Range

With Sheets("Feuil1")
  Set xrg = .Range("A" & Rows.Count).End(xlUp)
  xrg.Resize(1, 8).Copy xrg.Offset(1)
  xrg.Offset(1, 0) = xrg + 1
  xrg.Offset(1, 1) = Chr(PasCoche)
  xrg.Offset(1, 2) = ""
  xrg.Offset(1, 3) = Chr(PasCoche)
  xrg.Offset(1, 4) = Chr(PasCoche)
  xrg.Offset(1, 5) = ""
  xrg.Offset(1, 6) = Chr(PasCoche)
  xrg.Offset(1, 7) = ""
  xrg.Offset(1).EntireRow.RowHeight = xrg.EntireRow.RowHeight
End With

End Sub

nota: Voir fichier v2 (avec option raz et une petite correction du v1) dans message suivant #3
 
Dernière édition:
Vote positif 0 Vote négatif
mapomme

mapomme

XLDnaute Barbatruc
Supporter XLD
Re : Conserver la même checkbox sur toutes les lignes

(re) Bonsoir siocnarf,

Avec l'option de RAZ de toutes les Checkbox + une correction du précédent fichier.

Le code de la procédure raz dans module2:
VB: 
Sub raz()
Dim xrg As Range

If MsgBox("Etes vous certain de vouloir décocher toutes les checkBox ?", _
    Buttons:=vbDefaultButton2 + vbYesNo + vbQuestion) = vbYes Then
  With Sheets("Feuil1")
    Set xrg = .Range("A" & Rows.Count).End(xlUp)
    Set xrg = .Range(.Range("A4"), xrg)
    xrg.Offset(0, 1) = Chr(PasCoche)
    xrg.Offset(0, 2) = ""
    xrg.Offset(0, 3) = Chr(PasCoche)
    xrg.Offset(0, 4) = Chr(PasCoche)
    xrg.Offset(0, 5) = ""
    xrg.Offset(0, 6) = Chr(PasCoche)
    xrg.Offset(0, 7) = ""
  End With
End If
End Sub
 

Pièces jointes

  • Conserver la même checkbox sur toutes les lignes v2.xls
    78.5 KB · Affichages: 74
Vote positif 0 Vote négatif
mapomme

mapomme

XLDnaute Barbatruc
Supporter XLD
Re : Conserver la même checkbox sur toutes les lignes

Bonjour siocnarf,

L'instruction qui coche/décoche se trouve dans la macro évènementielle Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean).

On regarde d'abord si la cellule sur laquelle on a double-cliqué (Target) est en police Wingdings
If Target.Font.Name = "Wingdings" Then

Si oui alors on change l'état de la cellule par l'instruction:
Target = IIf(Target = Chr(PasCoche), Chr(Coche), Chr(PasCoche)) qui peut s'interpréter comme suit:

Si Target est égal au caractère Chr(PasCoche) alors on place dans Target le caractère Chr(Coche) sinon on y place le caractère Chr(PasCoche).

Ensuite, en fonction de la colonne de Target, via le select (Select Case Target.Column... End Select), on fait ce qui est à faire selon le nouvel état de Target (coché ou non).
 
Vote positif 0 Vote négatif
S

siocnarf

XLDnaute Occasionnel
Re : Conserver la même checkbox sur toutes les lignes

Bonjour,

Je me permets de vous relancer. Votre macro fonctionne très bien mais cela m'amène une problématique.
Cela fait un case extrèmement long et si j'ajoute une colonne alors toute la numérotation est à recorriger. Comment pourrais-je contourner ce problème?

Code: 
Option Explicit

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

If Target.Font.Name = "Wingdings" Then
  'on passe de coché à décoché et vice-versa
  Target = IIf(Target = Chr(PasCoche), Chr(Coche), Chr(PasCoche))
  Cancel = True
  Select Case Target.Column
    Case Range("B1").Column
      Target.Offset(0, 1) = IIf(Target = Chr(Coche), 20, "")
    Case Range("D1").Column
       ' Colonne D - Vol
       'If Target = Chr(Coche) Then MsgBox ("Aller porter plainte")
       Target.Offset(0, 1) = IIf(Target = Chr(Coche), 15, "")
    Case Range("F1").Column
      Target.Offset(0, 1) = IIf(Target = Chr(Coche), 10, "")
    Case Range("H1").Column
        'Colonne H - Perte
      Target.Offset(0, 1) = IIf(Target = Chr(Coche), 10, "")
    Case Range("K1").Column
      Target.Offset(0, 1) = IIf(Target = Chr(Coche), 20, "")
    Case Range("M1").Column
      Target.Offset(0, 1) = IIf(Target = Chr(Coche), 10, "")
    Case Range("O1").Column
      Target.Offset(0, 1) = IIf(Target = Chr(Coche), 5, "")
    Case Range("R1").Column
      Target.Offset(0, 1) = IIf(Target = Chr(Coche), 20, "")
    Case Range("T1").Column
      Target.Offset(0, 1) = IIf(Target = Chr(Coche), 20, "")
    Case Range("V1").Column
      Target.Offset(0, 1) = IIf(Target = Chr(Coche), 20, "")
    Case Range("X1").Column
      Target.Offset(0, 1) = IIf(Target = Chr(Coche), 20, "")
    Case Range("Z1").Column
      Target.Offset(0, 1) = IIf(Target = Chr(Coche), 20, "")
    Case Range("AB1").Column
      Target.Offset(0, 1) = IIf(Target = Chr(Coche), 20, "")
    Case Range("AE1").Column
      Target.Offset(0, 1) = IIf(Target = Chr(Coche), -100, "")
    Case Range("AG1").Column
        'Colonne AG -  100 et plus
      Target.Offset(0, 1) = IIf(Target = Chr(Coche), 20, "")
    Case Range("AI1").Column
        'Colonne AI -  De 11 à 100
      Target.Offset(0, 1) = IIf(Target = Chr(Coche), 10, "")
    Case Range("AK1").Column
        'Colonne AK -  De 1 à 10
      Target.Offset(0, 1) = IIf(Target = Chr(Coche), 5, "")
    Case Range("AN1").Column
        'Colonne AN -  100 et plus
      Target.Offset(0, 1) = IIf(Target = Chr(Coche), 20, "")
    Case Range("AP1").Column
        'Colonne AP -  De 11 à 100
      Target.Offset(0, 1) = IIf(Target = Chr(Coche), 10, "")
    Case Range("AR1").Column
        'Colonne AR -  De 1 à 10
      Target.Offset(0, 1) = IIf(Target = Chr(Coche), 5, "")
    Case Range("AU1").Column
      Target.Offset(0, 1) = IIf(Target = Chr(Coche), -215, "")
   Case Range("AW1").Column
      Target.Offset(0, 1) = IIf(Target = Chr(Coche), -25, "")
   Case Range("AY1").Column
      Target.Offset(0, 1) = IIf(Target = Chr(Coche), -20, "")

  End Select
End If

End Sub

Merci,

François
 
Vote positif 0 Vote négatif

Discussions similaires

F
  • Question
Microsoft 365 Associer lancement macro à une CheckBox
Réponses
7
Affichages
600
Fab117
F
P
  • Résolu(e)
Microsoft 365 Exporte format d'impression à d'autres onglet
Réponses
3
Affichages
155
PatrickNyon
P
Y
  • Résolu(e)
XL 2013 Surligner une ligne si curseur sur la ligne et dans une zone définie
Réponses
2
Affichages
106
Yvan1
Y
F
  • Question
XL 2019 l'indice n'appartient pas à la sélection
Réponses
9
Affichages
545
job75
job75
T
  • Question
Microsoft 365 Cocher automatiquement des checkbox avec des conditions
2
Réponses
24
Affichages
1 K
TCHIS
T
O
  • Question
Microsoft 365 Masquer plusieurs lignes sur plusieurs onglets
Réponses
2
Affichages
250
Orson83
Orson83
lynyrd
  • Résolu(e)
XL 2016 Supprimer 1 sur 13
Réponses
6
Affichages
132
lynyrd
lynyrd
S
  • Résolu(e)
Microsoft 365 Récupérer la date dans un calendrier
Réponses
2
Affichages
110
sebastien176
S
V
  • Résolu(e)
XL 2016 Facturier : Retour à la ligne sur la facture
2
Réponses
19
Affichages
558
Vermithor
V
E
  • Résolu(e)
Microsoft 365 Boucle sur lignes <>0
Réponses
2
Affichages
147
eric72
E

Membres actuellement en ligne

14 membres et 342 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 199
Messages
2 086 160
Membres
103 147
dernier inscrit
tubaman