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

Dravol

XLDnaute Junior
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
 
Solution
Mettez le début comme ça :
VB:
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

Dranreb

XLDnaute Barbatruc
Bonjour.
Je le ferais peut être comme ça :
VB:
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 :
1602158895407.png
 

Dravol

XLDnaute Junior
Bonjour.
Je le ferais peut être comme ça :
VB:
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

XLDnaute Barbatruc
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
 
Dernière édition:

Dranreb

XLDnaute Barbatruc
Mettez le début comme ça :
VB:
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
 

Discussions similaires

Réponses
4
Affichages
151

Statistiques des forums

Discussions
297 960
Messages
1 964 646
Membres
200 628
dernier inscrit
pop600