[VBA] Dupliquer une liste déroulante sur plusieurs cellules

Bonjour à tous,

Tout d'abord, je vous remercie pour ce que vous faites, ça aide beaucoup!

Étant novice sur Excel et notamment VBA, je me permets de venir vers vous.

Vous trouverez en pièce-jointe un fichier Excel:

Composition du fichier Excel:

• Feuille 1: PARAMETRE => cellulle F7: liste déroulante de la colonne B de la feuille BDD
• Feuille 2: SEMAINE_20 => cellules B12:B17 et cellules B22:B26 sont des listes déroulantes de la colonne C de la feuille BDD
• Feuille 3: BDD

Mon problème:

- Feuille 2 : SEMAINE_20 => le codage VBA me permettant d'avoir une liste déroulante dans les cellules B12:B17 et cellules B22:B26 est dupliquer autant de fois que de cellules. J'aimerai avoir un code pour la plage B12:B17 et un autre code pour la plage B22:B26. Car dans le réalité mes deux plages ont beaucoup plus de lignes que dans l'exemple.

Ci-dessous un extrait du code (pour info c'est code que j'ai trouver sur un forum et que j'ai adapté à mon cas):

[b]Private Sub Worksheet_SelectionChange(ByVal Target As Range)

'-- ligne12

If Target.Address = "$B$12" Then

Set d1 = CreateObject("Scripting.Dictionary")

For Each c In [TYPE_DEPARTEMENT]

tmp = c.Offset(0, -1): If tmp = "" Then tmp = c.Offset(0, -1).End(xlUp)

If tmp = Range("E4") Then d1(c.Value) = ""

Next c

Target.Validation.Delete

If d1.Count > 0 Then Target.Validation.Add xlValidateList, Formula1:=Join(d1.keys, ",")

End If

'-- ligne13

If Target.Address = "$B$13" Then

Set d1 = CreateObject("Scripting.Dictionary")

For Each c In [TYPE_DEPARTEMENT]

tmp = c.Offset(0, -1): If tmp = "" Then tmp = c.Offset(0, -1).End(xlUp)

If tmp = Range("E4") Then d1(c.Value) = ""

Next c

Target.Validation.Delete

If d1.Count > 0 Then Target.Validation.Add xlValidateList, Formula1:=Join(d1.keys, ",")

End If[/b]

Désolé, si ce n'est pas clair, je reste à votre disposition si vous souhaitez plus de précisions.

Merci d'avance de votre aide.

Cordialement

Monsach

Bonjour,

Une proposition pour remplacer ton code ...

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

   If Not Intersect(Range("B12:B17, B22:B26"), Range(Target.Address)) Is Nothing Then
      If Target.Cells.Count = 1 Then
         Set d1 = CreateObject("Scripting.Dictionary")
         For Each c In [TYPE_DEPARTEMENT]
            tmp = c.Offset(0, -1): If tmp = "" Then tmp = c.Offset(0, -1).End(xlUp)
            If tmp = Range("E4") Then d1(c.Value) = ""
         Next c
         Target.Validation.Delete
         If d1.Count > 0 Then Target.Validation.Add xlValidateList, Formula1:=Join(d1.keys, ",")
      End If
   End If
End Sub

ric

Bonjour ric ,

Je te remercie pour ta réactivité! Ça fonctionne parfaitement!

Le problème est donc résolu.

Cordialement

Monsach