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

Dravol · 8 Octobre 2020

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 · 8 Octobre 2020

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 · 8 Octobre 2020

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 :

Dravol · 8 Octobre 2020

Bonjour Dranreb

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

A+

Dravol · 8 Octobre 2020

Dranreb à dit:

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 · 8 Octobre 2020

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 · 8 Octobre 2020

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 · 8 Octobre 2020

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

Dravol · 9 Octobre 2020

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

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

Dravol

XLDnaute Junior

Dranreb

Dranreb

XLDnaute Barbatruc

Dravol

XLDnaute Junior

Dravol

XLDnaute Junior

Dranreb

XLDnaute Barbatruc

Dravol

XLDnaute Junior

Pièces jointes

Dranreb

XLDnaute Barbatruc

Dravol

XLDnaute Junior

Discussions similaires