Option Explicit Const Marque As String = "\/" Public Maplage As Range Sub PseudoCheckBox(ByRef Target As Range, Optional ByVal Colonne As String = "A") Dim MaCellule As Range, TempPlage As Range 'on verifi que la variable target pointe sur la colonne specifiée et sur une cellule unique On Local Error Resume Next If Target.Column Columns(Colonne).Column And Target.Cells.Count 1 Then If Not Err = 0 Then Exit Sub 'on desactive la mise a jour de l'affichage Application.ScreenUpdating = False Application.EnableEvents = False 'si la variable target pointe sur une cellule qui contient deja la marque If Target.Value = Marque Then 'on efface le contenu de la cellule Target.ClearContents 'on vide la variable MaPlage Set Maplage = Nothing 'on recuppere toute les cellules qui contiennent du text sur la colonne spécifiée Set TempPlage = Columns(Colonne).SpecialCells(xlCellTypeConstants, 2) 'on vas verifier si ce text est une marque For Each MaCellule In TempPlage If MaCellule.Value = Marque Then 'si c'est une marque 'on reconstruit alors MaPlage If Maplage Is Nothing Then 'premier passage 'entirerow sert a selectionner toute la ligne de la cellule pointee par MaCellule Set Maplage = MaCellule.EntireRow Else 'les autres passages Set Maplage = Union(Maplage, MaCellule.EntireRow) End If End If Next On Error Resume Next Maplage.Select 'si la variable target pointe sur une cellule vide ElseIf Target.Value = "" Then With Target .Value = Marque 'on lui ajoute une marque 'on met en forme la cellule .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter End With 'on met en forme la marque With Target.Characters(Start:=1, Length:=1).Font .Name = "Arial" .Size = 7 End With With Target.Characters(Start:=2, Length:=1).Font .Name = "Arial" .FontStyle = "Italic" .Size = 12 End With On Error Resume Next Maplage.Select Set Maplage = Union(Selection, Rows(Target.Row)) Maplage.Select End If 'on reactive la mise a jour de l'affichage Application.ScreenUpdating = True Application.EnableEvents = True 'si on clic en dehors de la colonne specifiée elle sera vidée de ses marques (Option) ElseIf Not Target.Column Columns(Colonne).Column And Target.Cells.Count 1 Then 'Columns(Colonne).ClearContents 'Set Maplage = Nothing 'Target.Select End If End Sub
Option Explicit Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) 'exemple d'utilisation: les cellules de la colonne "B" se transforment en Checkbox ' pour permettre la selection ou deselection de ligne entiere, par simple clic(dans la colonne B) Call PseudoCheckBox(Target, "B") End Sub
Vous n’avez pas trouvé la réponse que vous recherchez ?
Posez votre questionSub EcrireCode() ' Ce code permet de recopier la macro Private Sub Worksheet_SelectionChange dans les feuilles bateaux ' c'est elle qui permet de faire fonctionner le principe de click dans la colonne 20 qui donne l'attribut ' VRAI ou FAUX dans la colonne 21 Dim i, LeCode(1 To 15) Dim NomClasseur As String, NomFeuil As String Dim Wb As Workbook NomClasseur = ActiveWorkbook.Name LeCode(1) = "Private Sub Worksheet_SelectionChange(ByVal Target As Range)" LeCode(2) " NbreLignes3+ Application.CountA(Range(""E1:E65536""))" LeCode(3) "Non ""NON" LeCode(4) "Oui ""OUI" LeCode(5) = " If Intersect(Target, Range(""T5:T"" & NbreLignes)) Is Nothing Then Exit Sub" LeCode(6) = " Select Case Target.Offset(0, 1)" LeCode(7) " Case Is Oui" LeCode(8) " Target.Offset(0, 1) ""NON" LeCode(9) " Case Is Non" LeCode(10) " Target.Offset(0, 1) ""OUI" LeCode(11) = " Case Else" LeCode(12) " Target.Offset(0, 1) ""OUI" LeCode(13) = " End Select" LeCode(14) = "Target.Offset(0, 1).Select" LeCode(15) = "End sub" Set Wb = Workbooks(NomClasseur) For X = 2 To Compteur + 1 For i = 1 To 15 Wb.VBProject.VBComponents("Feuil" & X).CodeModule.InsertLines i, LeCode(i) Next i Next X End Sub