XL 2019 Créer une boucle ou répéter une macro sur plusieurs lignes

[Dravol]

Bonjour à tous,

Je souhaiterai répéter ma macro ci-dessous sur plusieurs lignes (jusqu'à la ligne 48).
Dans l'exemple ci-dessous je l'ai crée pour 3 lignes, j'aimerai éviter de le faire 48 fois

Avez-vous une idée comment faire svp (faut-il faire une boucle ou y a t-il un autre moyen) ? :

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim isect, Z$, plage
If Target.Count = 1 Then
Z = Target.Value
plage = "h18"
Set isect = Application.Intersect(Target, Range(plage))
If Not isect Is Nothing Then
Target = IIf(Z = "", "ü", "")
Range("j18") = IIf(Target = "", "ü", "")
End If
plage = "j18"
Set isect = Application.Intersect(Target, Range(plage))
If Not isect Is Nothing Then
Target = IIf(Z = "", "ü", "")
Range("h18") = IIf(Target = "", "ü", "")
End If
plage = "Q24"
Set isect = Application.Intersect(Target, Range(plage))
If Not isect Is Nothing Then
Target = IIf(Z = "", "ü", "")
Range("r24") = IIf(Target = "", "ü", "")
End If
plage = "r24"
Set isect = Application.Intersect(Target, Range(plage))
If Not isect Is Nothing Then
Target = IIf(Z = "", "ü", "")
Range("s24") = IIf(Target = "", "ü", "")
End If
plage = "s24"
Set isect = Application.Intersect(Target, Range(plage))
If Not isect Is Nothing Then
Target = IIf(Z = "", "ü", "")
Range("q24") = IIf(Target = "", "ü", "")
End If
plage = "q24"
Set isect = Application.Intersect(Target, Range(plage))
If Not isect Is Nothing Then
Target = IIf(Z = "", "ü", "")
Range("s24") = IIf(Target = "", "ü", "")
End If
plage = "r24"
Set isect = Application.Intersect(Target, Range(plage))
If Not isect Is Nothing Then
Target = IIf(Z = "", "ü", "")
Range("q24") = IIf(Target = "", "ü", "")
End If
plage = "s24"
Set isect = Application.Intersect(Target, Range(plage))
If Not isect Is Nothing Then
Target = IIf(Z = "", "ü", "")
Range("r24") = IIf(Target = "", "ü", "")
End If
'ligne suivante
plage = "Q25"
Set isect = Application.Intersect(Target, Range(plage))
If Not isect Is Nothing Then
Target = IIf(Z = "", "ü", "")
Range("r25") = IIf(Target = "", "ü", "")
End If
plage = "r25"
Set isect = Application.Intersect(Target, Range(plage))
If Not isect Is Nothing Then
Target = IIf(Z = "", "ü", "")
Range("s25") = IIf(Target = "", "ü", "")
End If
plage = "s25"
Set isect = Application.Intersect(Target, Range(plage))
If Not isect Is Nothing Then
Target = IIf(Z = "", "ü", "")
Range("q25") = IIf(Target = "", "ü", "")
End If
plage = "q25"
Set isect = Application.Intersect(Target, Range(plage))
If Not isect Is Nothing Then
Target = IIf(Z = "", "ü", "")
Range("s25") = IIf(Target = "", "ü", "")
End If
plage = "r25"
Set isect = Application.Intersect(Target, Range(plage))
If Not isect Is Nothing Then
Target = IIf(Z = "", "ü", "")
Range("q25") = IIf(Target = "", "ü", "")
End If
plage = "s25"
Set isect = Application.Intersect(Target, Range(plage))
If Not isect Is Nothing Then
Target = IIf(Z = "", "ü", "")
Range("r25") = IIf(Target = "", "ü", "")
End If
'ligne suivante
plage = "Q26"
Set isect = Application.Intersect(Target, Range(plage))
If Not isect Is Nothing Then
Target = IIf(Z = "", "ü", "")
Range("r26") = IIf(Target = "", "ü", "")
End If
plage = "r26"
Set isect = Application.Intersect(Target, Range(plage))
If Not isect Is Nothing Then
Target = IIf(Z = "", "ü", "")
Range("s26") = IIf(Target = "", "ü", "")
End If
plage = "s26"
Set isect = Application.Intersect(Target, Range(plage))
If Not isect Is Nothing Then
Target = IIf(Z = "", "ü", "")
Range("q26") = IIf(Target = "", "ü", "")
End If
plage = "q26"
Set isect = Application.Intersect(Target, Range(plage))
If Not isect Is Nothing Then
Target = IIf(Z = "", "ü", "")
Range("s26") = IIf(Target = "", "ü", "")
End If
plage = "r26"
Set isect = Application.Intersect(Target, Range(plage))
If Not isect Is Nothing Then
Target = IIf(Z = "", "ü", "")
Range("q26") = IIf(Target = "", "ü", "")
End If
plage = "s26"
Set isect = Application.Intersect(Target, Range(plage))
If Not isect Is Nothing Then
Target = IIf(Z = "", "ü", "")
Range("r26") = IIf(Target = "", "ü", "")
End If

 

[Dranreb]

Bonjour.
Je le ferais peut être comme ça :

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim HCoché As Boolean, TV()
If Target.CountLarge <> 1 Then Exit Sub
If Not Intersect([H18,J18], Target) Is Nothing Then
   HCoché = IsEmpty([J18].Value)
   [H18].Value = IIf(HCoché, Empty, ChrW(&H2713))
   [J18].Value = IIf(HCoché, ChrW(&H2713), Empty)
ElseIf Not Intersect([Q24:S48], Target) Is Nothing Then
   TV = Array(Empty, Empty, Empty)
   TV(Target.Column - 17) = ChrW(&H2713)
   [Q:S].Rows(Target.Row).Value = TV
   End If
End Sub

Police normale utilisant ce caractère :

 

[Dravol]

Bonjour Dranreb

Merci c'est top et bien plus simple ....

A+

 

[Dravol]

Bonjour.
Je le ferais peut être comme ça :

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim HCoché As Boolean, TV()
If Target.CountLarge <> 1 Then Exit Sub
If Not Intersect([H18,J18], Target) Is Nothing Then
   HCoché = IsEmpty([J18].Value)
   [H18].Value = IIf(HCoché, Empty, ChrW(&H2713))
   [J18].Value = IIf(HCoché, ChrW(&H2713), Empty)
ElseIf Not Intersect([Q24:S48], Target) Is Nothing Then
   TV = Array(Empty, Empty, Empty)
   TV(Target.Column - 17) = ChrW(&H2713)
   [Q:S].Rows(Target.Row).Value = TV
   End If
End Sub

Police normale utilisant ce caractère :
Regarde la pièce jointe 1080875

Par contre ma seconde macro qui fonctionnait avec le post #1 ne marche plus ?

Vous savez pourquoi ?

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim HCoché As Boolean, TV()
If Target.CountLarge <> 1 Then Exit Sub
If Not Intersect([H18,J18], Target) Is Nothing Then
HCoché = IsEmpty([J18].Value)
[H18].Value = IIf(HCoché, Empty, ChrW(&H2713))
[J18].Value = IIf(HCoché, ChrW(&H2713), Empty)
ElseIf Not Intersect([Q24:S43], Target) Is Nothing Then
TV = Array(Empty, Empty, Empty)
TV(Target.Column - 17) = ChrW(&H2713)
[Q:S].Rows(Target.Row).Value = TV
ElseIf Not Intersect([Q45:S48], Target) Is Nothing Then
TV = Array(Empty, Empty, Empty)
TV(Target.Column - 17) = ChrW(&H2713)
[Q:S].Rows(Target.Row).Value = TV
End If
If Target.Address = Range("d19").Address And Range("d19").Value < 35 Then
'If Target.Address = Range("d19").MergeArea.Address And Range("d19").Value < 35 Then
Dim I
For I = 1 To 3 ' Loop 3 times.
Beep
'PlaySound ThisWorkbook.Path & "\0257", 0, 1
MsgBox "Attention valeur hors tolérance"
Next
End If

End Sub

 

[Dranreb]

Je pensais qu'il n'y avait rien d'autre à faire si Target.CountLarge > 1
Mettez peut être vos autres instruction avant le test ou soumettez tous les 1ers cas à un IF Target.CountLarge = 1 Then avec un End If à la fin.

Remarque: Un seul paquet avec ElseIf Not Intersect([Q24:S43,Q45:S48], Target) Is Nothing Then devrait marcher aussi

 

[Dravol]

Pour votre remarque, c'est bon merci.

Par contre je n'arrive tjrs pas à faire fonctionner la 2ieme macro (en même tps je suis pas très doué ...)

 

[Dranreb]

Mettez le début comme ça :

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim HCoché As Boolean, TV()
If Target.CountLarge = 1 Then
   If Not Intersect([H18,J18], Target) Is Nothing Then
      HCoché = IsEmpty([J18].Value)
      [H18].Value = IIf(HCoché, Empty, ChrW(&H2713))
      [J18].Value = IIf(HCoché, ChrW(&H2713), Empty)
   ElseIf Not Intersect([Q24:S43,Q45:S48], Target) Is Nothing Then
      TV = Array(Empty, Empty, Empty)
      TV(Target.Column - 17) = ChrW(&H2713)
      [Q:S].Rows(Target.Row).Value = TV
      End If: End If

 

[Dravol]

Bonjour Dranreb

Merci. parfait

Je vais poster un autre sujet pour avoir l'alerte "beep" après la saisie et pas au moment du clique de la cellule.

Sujet soldé pour ma part, ty