Dupliquer une cellule contenant une case à cocher en déplaçant la liaison

Le 19/08/2022 à 21:59

Bonjour,

Dans le classeur ci-joint, est-il possible de dupliquer la cellule I2 dans tout le tableau de droite, sans que les cases à cocher soient liées (cf. I3) ? Je peux faire un clic droit > Format de contrôle et changer manuellement la cellule liée (comme dans la cellule J2), mais comme il y a 115 cellules dans mon tableau, ça va être long ! Connaissez-vous un moyen plus rapide ?

Merci d'avance de votre aide !

G.

20classeur1.xlsx (18.19 Ko)
Le 20/08/2022 à 00:14

Bonsoir Gab,

En retour ton fichier avec la macro CheckCase.

Faire Affichage dans le menu général puis choisir Macros puis Afficher les macros.

Ou bien aller directement dans l'éditeur VBA pour la lancer.

Cela prendra 25 à 30 secondes pour terminer l'opération.

45classcheckboxes.xlsm (23.16 Ko)
Le 20/08/2022 à 04:39

Merci beaucoup pour cette proposition. Par contre, j'ai un petit blocage. Ça marche pour le premier, puis j'ai un message d'erreur :

image 14328 6300471bbfceb907813062 - excel
Le 20/08/2022 à 09:31

bonjour,

Sub Effacer_Tout_Les_FormControls()
     '****************************************************
     'efface tout les FormControls (=type 8) dans les colonnes I:M
     '****************************************************
     t = Timer
     For Each shp In ActiveSheet.Shapes
          If shp.Type = 8 And Not Intersect(shp.TopLeftCell, Range("I:M")) Is Nothing Then shp.Delete
     Next
     MsgBox "Prêt en " & Format(Timer - t, "0.0\s")
End Sub

Sub Ajouter_Cases_A_Cocher()
     '*******************************
     'ajoute des checkboxes dans une plage
     '******************************
     Dim c, CHB
     t = Timer
     Application.ScreenUpdating = False
     For Each c In Range("I2:M24").Cells
          Set CHB = c.Parent.CheckBoxes.Add(0, 1, 1, 0)
          With CHB
               .Top = c.Top     'les 4 dimensions
               .Left = c.Left
               .Width = c.Offset(, 1).Left - c.Left
               .Height = c.Offset(1).Top - c.Top

               .Locked = False
               .Caption = "Pour " & c.Offset(, -7).Address(0, 0)
               .Name = c.Address
               .Value = xlOff
               .LinkedCell = c.Address
               .Display3DShading = True
          End With
          c.Font.Color = RGB(178, 178, 178)     'les valeurs dans la celulles seront gris
     Next
     Application.ScreenUpdating = False

     MsgBox "Prêt en " & Format(Timer - t, "0.0\s")
End Sub
Le 20/08/2022 à 09:41

Bonjour Gab,

Cela peut arriver, si l'ordi est occupé sur d'autres tâches (surtout au démarrage) ou Internet activé.

J'ai modifié afin que le message d'erreur ne perturbe pas le déroulement.

Ci-dessous, le code modifié.

Sub CheckCase()
'
'Ajout selon modèle d'un Checkbox déjà présent
Nbre = ActiveSheet.Shapes.Count ' Déplacé en 1ière ligne
If Nbre > 114 Then MsgBox "Tableau déjà complet": Exit Sub ' Ajouté
MsgBox "Cliquez sur Ok pour lancer la copie, temps ~ 30s"
Application.ScreenUpdating = False
For Lig = 2 To 24
For Col = 9 To 13
N = N + 1
On Error GoTo Saut ' Ajouté 
If N <= Nbre Then GoTo Saut
    ActiveSheet.Shapes.Range(Array("Check Box 2")).Select
    Selection.Copy
    ActiveSheet.Paste
    With Selection
        .Name = "Check Box " & N
        .Value = xlOff
        .LinkedCell = Cells(Lig, Col).Address
        .Display3DShading = True
        .Top = Cells(Lig, Col).Top
        .Left = Cells(Lig, Col).Left
    End With
Saut:
'
Next Col
Application.Wait Now + TimeValue("00:00:01")
Next Lig
Range("N1").Select
Application.ScreenUpdating = True
MsgBox "L'opération Check Box est terminée, cliquez sur OK"
End Sub

Une fois les 115 checkBox posés, un message avertira que le tableau est complet.

Si après, besoin d'un tableau plus grand (exemple: 125 checkBox ) il faudra corriger la valeur de la ligne IF Nbre >114 par la valeur 124.

Le programme insérera les nouveaux après le 115 ième.

Le 20/08/2022 à 21:58

Merci beaucoup pour vos réponses !

X Cellus, j'ai toujours le même message d'erreur avec le nouveau code. Par contre, le code de BsAlv fonctionne !

Merci Merci Merci

Le 20/08/2022 à 22:15

le problème avec la macro de @X Cellus, c'est que le dernier "Paste" n'est pas encore fini quand le prochaine paste y est déjà. Il faut freiner VBA un petit peu (=100 à 200 millisecondes)

Sub CheckCase()
     '
     ' Macro1 Macro
     MsgBox "Cliquez sur Ok pour lancer la copie, temps ~ 30s"
     Application.ScreenUpdating = False
     Nbre = ActiveSheet.Shapes.Count
     For Lig = 2 To 24
          For Col = 9 To 13
               N = N + 1
               If N <= Nbre Then GoTo Saut
               ActiveSheet.Shapes.Range(Array("Check Box 2")).Select
               Selection.Copy
               ActiveSheet.Paste
               Attend     'ralentir Excel un tout petit peu
               With Selection
                    .Name = "Check Box " & N
                    .Value = xlOff
                    .LinkedCell = Cells(Lig, Col).Address
                    .Display3DShading = True
                    .Top = Cells(Lig, Col).Top
                    .Left = Cells(Lig, Col).Left
               End With
Saut:
     '
          Next Col
     'Application.Wait Now + TimeValue("00:00:01")
     Next Lig
     Range("N1").Select
     Application.ScreenUpdating = True
     MsgBox "L'opération Check Box est terminée, cliquez sur OK"
End Sub

Sub Attend()

     t = Timer
     Do
          DoEvents
     Loop While t < Timer And Timer < t + 0.2     'un boucle pendant 200 millisecondes

End Sub
Le 20/08/2022 à 23:00

Ça marche, si on "Attend" AVANT le collage fatal

Sub CheckCase()
     '
     ' Macro1 Macro
     MsgBox "Cliquez sur Ok pour lancer la copie, temps ~ 30s"
     Application.ScreenUpdating = False
     Nbre = ActiveSheet.Shapes.Count
     For Lig = 2 To 24
          For Col = 9 To 13
               N = N + 1
               If N <= Nbre Then GoTo Saut
               ActiveSheet.Shapes.Range(Array("Check Box 2")).Select
               Selection.Copy
               Attend     'ralentir Excel un tout petit peu
               ActiveSheet.Paste
               With Selection
                    .Name = "Check Box " & N
                    .Value = xlOff
                    .LinkedCell = Cells(Lig, Col).Address
                    .Display3DShading = True
                    .Top = Cells(Lig, Col).Top
                    .Left = Cells(Lig, Col).Left
               End With
Saut:
     '
          Next Col
     'Application.Wait Now + TimeValue("00:00:01")
     Next Lig
     Range("N1").Select
     Application.ScreenUpdating = True
     MsgBox "L'opération Check Box est terminée, cliquez sur OK"
End Sub

Sub Attend()

     t = Timer
     Do
          DoEvents
     Loop While t < Timer And Timer < t + 0.25     'un boucle pendant 250 millisecondes

End Sub

J'ai aussi dû augmenter un chouïa la pause sous la pression du syndicat Erreur 1004...

Thanks again!

Le 20/08/2022 à 23:12

il est possible que si vous fermez l'internet et les autres applications ouverts, que cela fonctionne avec 150 millisecondes, mais demain, au moment où vous recevez des mails avec Outlook (ou un autre) ou d'autres circonstances et vous lancer de nouveau cette macro que vous avez besoin de 300 millisecondes. C'est bizarre ... .

Le 21/08/2022 à 00:36

Peut-être lié à la disponibilité/rapidité du système au moment du test ?

Sinon... ça fait deux heures que je cherche quelque chose que vous trouverez sans doute en cinq minutes : Je voudrais pouvoir mettre à jour le texte des cases à cocher avec le contenu de la cellule associée (.Caption = c.Offset(, -7).Value ou Selection.Characters.Text = c.Offset(, -7).Value). J'ai cherché des infos pour faire des boucles avec les Shapes, mais je n'arrive pas à m'en sortir...

Le 21/08/2022 à 01:35

dans mon premier exemple, 'j'avais

.Caption = "Pour " & c.Offset(, -7).Address(0, 0)

alors cela change en

.Caption = IIf(Len(c.Offset(, -7).Value) = 0, "Vide", c.Offset(, -7).Value) 'si la cellule est vide, alors on inscrit "vide", autrement le contenu de la cellule

Vous ne voulez pas que ce texte change en même temps que le contenu de la cellule change APRES la création de cette case à cocher, parce que dans ce cas, on a besoin d'un event "Worksheet_Change" ...

Le 21/08/2022 à 02:05

C'est pas tout à fait ça, mais finalement, j'ai fait en sorte que la manœuvre n'altère pas les cases cochées, comme ça, je peux reset et recharger les cases avec tous les noms sans souci :

               .Caption = c.Offset(, -7).Value
               .Name = c.Address
               If c.Value = True Then
               .Value = xlOn
               Else
               .Value = xlOff
               End If
               .LinkedCell = c.Address
               .Display3DShading = True
Le 21/08/2022 à 02:05

bonjour,

Private Sub Worksheet_Change(ByVal Target As Range)
     Dim shp
     Set c = Intersect(Target, Range("B2:F24"))     'on change quelque chose dans cette plage
     If c Is Nothing Then Exit Sub
     For Each c0 In c.Cells
          On Error Resume Next
          Set shp = Me.CheckBoxes(c0.Offset(, 7).Address)     '>>>>>>>>>>> CHECKBOXES !!!!!!, celui avec le nom de l'adresse de la cellule 7 à droite
          On Error GoTo 0
          If shp Is Nothing Then
               MsgBox "problème, le checkbox " & c0.Offset(, 7).Address & " n'existe pas"
          Else
               shp.Caption = IIf(Len(c0.Value) = 0, "Vide", c0.Value)     'si la cellule est vide, alors on inscrit "vide", autrement le contenu de la cellule
          End If
     Next
End Sub
Le 21/08/2022 à 02:10

.value=iif(c.value=true, xlon,xloff)

cela est plus court et mieux lisible, je pense

 If c.Value = True Then
               .Value = xlOn
               Else
               .Value = xlOff
               End If
Le 21/08/2022 à 02:33

Merci

Rechercher des sujets similaires à "dupliquer contenant case cocher deplacant liaison"