macro liée aux cases à cocher

[benoitalexis]

Bonjour,

J'ai peu de pratique des macros et autres prog. VBA sous excel et j'aimerais votre avis sur un problème qui me turlupine depuis quelques jours...
A partir d'une feuille excel (appelée base) qui liste des lignes correspondant à des situations à laquelle une catégorie de personne est exposée, se composant d'infos texte et chiffre : exposition, gravité, priorité, remarque et de cases à cocher qui valident la catégorie de personnel répondant à ces critères : Adm, sg, ai ou tech. Mon idée serait de créer des boutons macros nommés eux aussi Adm, sg, ai et tech, en tête de page, et qu'ils permettent de "coller" toutes les lignes relatives à leur intitulé propre sur une feuille séparée (qui pourrait être ainsi mise en page et imprimée à la demande). Biensûr une ligne peut être affectée à plusieurs catégories (voir toutes).
Je joins un fichier exemple à ce post qui reprend grosso modo les différentes infos à traiter.
D'avance merci pour votre coup de main.

A+

 

[job75]

Re : macro liée aux cases à cocher

Bonjour benoitalexis, bienvenue sur XLD,

Voyez si cette solution vous convient.

La macro dans un module (Alt+F11) :

Sub Copier()
Dim tablo, col As Byte, cel As Range
tablo = Array("Adm", "Sg", "ai", "tech")
col = Split(Application.Caller, " ")(1) - 32
With Sheets("Feuil1")
  .[A4:E65536].Clear
  .[A1] = tablo(col - 10)
  For Each cel In Range(Cells(4, col), Cells(65536, col).End(xlUp))
    If cel = True Then
      Intersect([A:E], Rows(cel.Row)).Copy .[A65536].End(xlUp)(2)
    End If
  Next
  .Activate
End With
End Sub

Et le fichier joint.

Pour lancer la macro, cliquez sur l'un des 4 boutons en feuille base.

La copie se trouve dans la feuille Feuil1.

A+

 

[benoitalexis]

Re : macro liée aux cases à cocher

Ok, exactement ça! Merci beaucoup.

Par contre je veux rajouter 2 colonnes dans la feuilles base et 2 boutons macros en plus et je but un peu sur les modif à faire dans le code, surtout pour les boutons macros, pour les colonnes je suppose qu'il faut corriger ligne 10 intersect([A:E]) en intersect([A:G])...

A+

 

[job75]

Re : macro liée aux cases à cocher

Bonjour Benoitalexis,

Je n'avais pas vu votre Edit.

Pour ajouter des colonnes et donc des boutons, il faut avoir bien compris comment fonctionne la macro.

L'important est que les numéros des boutons se suivent.

Pour ajouter 2 boutons (tec2 et tec3), j'ai dû tous les recréer : les noms des 6 boutons (vous les voyez affichés en haut à gauche après un clic droit) vont donc de Bouton 47 à Bouton 52.

Je n'ai pas créé de nouvelles cases à cocher, à vous de le faire.

Il faut faire des modifications mineures sur la macro (en rouge) :

Sub Copier()
Dim tablo, col As Byte, cel As Range
tablo = Array("Adm", "Sg", "ai", "tec1"[COLOR="Red"], "tec2", "tec3"[/COLOR])
col = Split(Application.Caller, " ")(1) - [COLOR="Red"]35 '35 = n° du 1er bouton - nombre de boutons - 6[/COLOR]
With Sheets("Feuil1")
  .[A4:E65536].Clear
  .[A1] = tablo(col - [COLOR="Red"]12[/COLOR]) [COLOR="Red"]'12 = nombre de boutons + 6[/COLOR]
  For Each cel In Range(Cells(4, col), Cells(65536, col).End(xlUp))
    If cel = True Then
      Intersect([A:E], Rows(cel.Row)).Copy .[A65536].End(xlUp)(2)
    End If
  Next
  .Activate
End With
End Sub

Fichier modifié joint.

A+

 

[benoitalexis]

Re : macro liée aux cases à cocher

Merci Job75, j'ai très bien compris et je me débrouille comme un grand... A+

 

[benoitalexis]

Re : macro liée aux cases à cocher

Bonjour, tout le monde,

Sur la même idée, en utilisant des checkbox plutôt que des cases à cocher (contrôle) je pourrais éviter de lier une cellule à la case à cocher? Ce serait plus facile dans la mise en place non? Quelle serait la différence dans le code, j'ai essayer de remplacer les 'cel par 'CheckBox, mais cela ne semble pas fonctionner.

A+

 

[job75]

Re : macro liée aux cases à cocher

Bonjour benoitalexis,

Merci de m'avoir relancé par MP, je n'avais pas vu votre post.

Pour un grand nombre de cases à cocher, la bonne solution n'est pas d'utiliser des objets (Contrôles ActiveX ou Formulaires).

Le plus simple est d'utiliser les caractères de codes 168 et 254 avec la police Wingdings.

1) Dans la feuille base, mettre les colonnes F à K au format police Wingdings.

2) Dans le code de cette feuille, copiez la macro :

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, Range("F4:K" & [A65536].End(xlUp).Row)) Is Nothing Then Exit Sub
Target = IIf(Target = Chr(168), Chr(254), Chr(168))
Cancel = True
End Sub

Double-clic sur les cellules de la plage F:K pour créer les caractères (faire d'abord la plage F4:K4 et la tirer vers le bas, c'est rapide).

3) Modifiez la macro dans le module (en rouge) :

Sub Copier()
Dim tablo, col As Byte, cel As Range
tablo = Array("Adm", "Sg", "ai", "tec1", "tec2", "tec3")
col = Split(Application.Caller, " ")(1) - [COLOR="Red"]41 '41 = n° du 1er bouton - n° de la colonne du 1er bouton[/COLOR]
With Sheets("Feuil1")
  .[A4:E65536].Clear
  .[A1] = tablo(col - [COLOR="Red"]6) '6 = n° de la colonne du 1er bouton (F)[/COLOR]
  For Each cel In Range(Cells(4, col), Cells(65536, col).End(xlUp))
    If cel = [COLOR="Red"]Chr(254)[/COLOR] Then
      Intersect([A:E], Rows(cel.Row)).Copy .[A65536].End(xlUp)(2)
    End If
  Next
  .Activate
End With
End Sub

Fichier joint.

Edition 1 : plus simples sans doute, les caractères £ et R avec la police Wingdings 2...

Edition 2 : si vous préférez, pour créer les caractères, vous pouvez utiliser le clic droit avec la macro :

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, Range("F4:K" & [A65536].End(xlUp).Row)) Is Nothing [COLOR="Red"]Or Target.Count > 1[/COLOR] Then Exit Sub
'etc...

Bonne continuation.

 

[job75]

Re : macro liée aux cases à cocher

Bonsoir benoit alexis,

Pour exploiter votre idée de créer des CheckBox (ActiveX), voici votre fichier modifié.

Pour déterminer la valeur de la CheckBox d'une cellule, je n'ai pas trouvé d'autre solution que de créer la fonction ValeurCheckBox qui étudie tous les objets de la feuille. C'est donc lourd en calcul...

Les macros dans le module :

Sub Copier()
Dim tablo, col As Byte, cel As Range
tablo = Array("Adm", "Sg", "ai", "tec1", "tec2", "tec3")
col = Split(Application.Caller, " ")(1) - 41 '41 = n° du 1er bouton - n° de la colonne du 1er bouton
With Sheets("Feuil1")
  .[A4:E65536].Clear
  .[A1] = tablo(col - 6) '6 = n° de la colonne du 1er bouton (F)
  For Each cel In Cells(4, col).Resize([A65536].End(xlUp).Row - 3)
    If [COLOR="Red"]ValeurCheckBox(cel)[/COLOR] Then
      Intersect([A:E], Rows(cel.Row)).Copy .[A65536].End(xlUp)(2)
    End If
  Next
  .Activate
End With
End Sub

Function ValeurCheckBox(cel As Range) As Boolean
Dim o As Object
For Each o In ActiveSheet.OLEObjects
If o.TopLeftCell.Address = cel.Address Then ValeurCheckBox = o.Object.Value: Exit Function
Next
End Function

Par ailleurs on se rend compte que les objets augmentent beaucoup la taille (en Ko) du fichier. Je suis obligé de le mettre sur Cijoint :

Cijoint.fr - Service gratuit de dépôt de fichiers

A+

 

[benoitalexis]

Re : macro liée aux cases à cocher

Merci Job75, j'ai appliqué la méthode "wingdings" qui est vraiment idéale pour mon tableau, j'ai modifié le code pour l'adapter à mon tableau qui a beaucoup évolué depuis le debut du post et tout fonctionne très bien.
merci pour tout.

A+