Appliquer VBA sur plusieurs lignes
Bonjour,
Je suis plus que novice sur VBA et j'ai adapté le code ci dessous à mon tableau mais je n'en suis pas l'auteur.
Ma problématique est de valider ce code sur les lignes allant de 14 à 64 et là elle se limite à la ligne 14.
Merci de votre aide
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Address = "$B$14" Then
Set d1 = CreateObject("Scripting.Dictionary")
For Each c In [produitvba]: d1(c.Value) = "": Next c
For Each c In d1.keys: temp = temp & c & ",": Next c
Target.Validation.Delete
Target.Validation.Add xlValidateList, Formula1:=Left(temp, Len(temp) - 1)
End If
'-- niv 2
If Target.Address = "$C$14" Then
Set d1 = CreateObject("Scripting.Dictionary")
For Each c In [parementvba]
If c.Offset(0, -1) = Target.Offset(0, -1) Then d1(c.Value) = ""
Next c
If d1.Count > 0 Then
For Each c In d1.keys: temp = temp & c & ",": Next c
Target.Validation.Delete
Target.Validation.Add xlValidateList, Formula1:=Left(temp, Len(temp) - 1)
End If
End If
'---niv3
If Target.Address = "$D$14" Then
Set d1 = CreateObject("Scripting.Dictionary")
For Each c In [finitionvba]
If c.Offset(0, -2) = Target.Offset(0, -2) And _
c.Offset(0, -1) = Target.Offset(0, -1) Then d1(c.Value) = ""
Next c
If d1.Count > 0 Then
For Each c In d1.keys: temp = temp & c & ",": Next c
Target.Validation.Delete
Target.Validation.Add xlValidateList, Formula1:=Left(temp, Len(temp) - 1)
End If
End If
'--- niv 4
If Target.Address = "$E$14" Then
Set d1 = CreateObject("Scripting.Dictionary")
For Each c In [Epaisseur_isolvba]
If c.Offset(0, -3) = Target.Offset(0, -3) And _
c.Offset(0, -2) = Target.Offset(0, -2) And _
c.Offset(0, -1) = Target.Offset(0, -1) Then d1(c.Value) = ""
Next c
If d1.Count > 0 Then
For Each c In d1.keys: temp = temp & c & ",": Next c
Target.Validation.Delete
Target.Validation.Add xlValidateList, Formula1:=Left(temp, Len(temp) - 1)
End If
End If
'--- niv 5
If Target.Address = "$F$14" Then
Set d1 = CreateObject("Scripting.Dictionary")
For Each c In [Epaisseur_chevronvba]
If c.Value <> "" Then
If c.Offset(0, -4) = Target.Offset(0, -4) And _
c.Offset(0, -3) = Target.Offset(0, -3) And _
c.Offset(0, -2) = Target.Offset(0, -2) And _
c.Offset(0, -1) = Target.Offset(0, -1) Then d1(c.Value) = ""
End If
Next c
If d1.Count > 0 Then
For Each c In d1.keys: temp = temp & c & ",": Next c
Target.Validation.Delete
Target.Validation.Add xlValidateList, Formula1:=Left(temp, Len(temp) - 1)
Else
MsgBox "pb:pas de hauteur"
Target.Validation.Delete
End If
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Address = "$B$15" Then
Set d1 = CreateObject("Scripting.Dictionary")
For Each c In [produitvba]: d1(c.Value) = "": Next c
For Each c In d1.keys: temp = temp & c & ",": Next c
Target.Validation.Delete
Target.Validation.Add xlValidateList, Formula1:=Left(temp, Len(temp) - 1)
End If
'-- niv 2
If Target.Address = "$C$15" Then
Set d1 = CreateObject("Scripting.Dictionary")
For Each c In [parementvba]
If c.Offset(0, -1) = Target.Offset(0, -1) Then d1(c.Value) = ""
Next c
If d1.Count > 0 Then
For Each c In d1.keys: temp = temp & c & ",": Next c
Target.Validation.Delete
Target.Validation.Add xlValidateList, Formula1:=Left(temp, Len(temp) - 1)
End If
End If
'---niv3
If Target.Address = "$D$15" Then
Set d1 = CreateObject("Scripting.Dictionary")
For Each c In [finitionvba]
If c.Offset(0, -2) = Target.Offset(0, -2) And _
c.Offset(0, -1) = Target.Offset(0, -1) Then d1(c.Value) = ""
Next c
If d1.Count > 0 Then
For Each c In d1.keys: temp = temp & c & ",": Next c
Target.Validation.Delete
Target.Validation.Add xlValidateList, Formula1:=Left(temp, Len(temp) - 1)
End If
End If
'--- niv 4
If Target.Address = "$E$15" Then
Set d1 = CreateObject("Scripting.Dictionary")
For Each c In [Epaisseur_isolvba]
If c.Offset(0, -3) = Target.Offset(0, -3) And _
c.Offset(0, -2) = Target.Offset(0, -2) And _
c.Offset(0, -1) = Target.Offset(0, -1) Then d1(c.Value) = ""
Next c
If d1.Count > 0 Then
For Each c In d1.keys: temp = temp & c & ",": Next c
Target.Validation.Delete
Target.Validation.Add xlValidateList, Formula1:=Left(temp, Len(temp) - 1)
End If
End If
'--- niv 5
If Target.Address = "$F$15" Then
Set d1 = CreateObject("Scripting.Dictionary")
For Each c In [Epaisseur_chevronvba]
If c.Value <> "" Then
If c.Offset(0, -4) = Target.Offset(0, -4) And _
c.Offset(0, -3) = Target.Offset(0, -3) And _
c.Offset(0, -2) = Target.Offset(0, -2) And _
c.Offset(0, -1) = Target.Offset(0, -1) Then d1(c.Value) = ""
End If
Next c
If d1.Count > 0 Then
For Each c In d1.keys: temp = temp & c & ",": Next c
Target.Validation.Delete
Target.Validation.Add xlValidateList, Formula1:=Left(temp, Len(temp) - 1)
Else
MsgBox "pb:pas de hauteur"
Target.Validation.Delete
End If
End If
End Sub
Bonjour,
c'est tout à fait normal qu'elle se limite au ligne 14, c'est à cause de ces ligne la :
If Target.Address = "$B$14" Then
If Target.Address = "$C$14" Then
If Target.Address = "$D$14" Then
.
.
.
.la condition d’exécution du est que la case sélectionner soit l'un des case désigner.
tester en remplaçant les condition par
if not application.intersect(target,range("B14:B64) is nothing then
if not application.intersect(target,range("C14:C64) is nothing then
if not application.intersect(target,range("D14:D64) is nothing then
.
.
.Ca fonctionne