XL 2013 Incrémenter une liste à partir d'une cellule de référence variable

[jbgaillard]

Bonjour,

J'aimerais pouvoir recopier une liste de valeurs à partir d'une cellule donnée mais cette cellule peut varier et est choisie par un utilisateur.

Je m'explique : j'ai une liste de valeurs à recopier en colonne P, dans une plage de cellules B2:K12, et l'utilisateur choisi dans cette plage la première cellules pour le recopiage (en mettant "OUI" sur La ligne 1 et colonne1 afin de définir la 1ère cellule, ici D5 dans l'exemple de mon fichier)

Avec un fichier cela sera peut être plus clair (un onglet données d'entrée, et l'onglet résultat que j'aimerais avoir)

Merci infiniment,

 

[soan]

Bonjour jbgaillard,

bienvenue sur le site XLD !

ouvre le fichier ci-joint, et fais Ctrl e ➯ travail effectué !

Option Explicit

Sub Essai()
  If ActiveSheet.Name <> "Données d'entrée" Then Exit Sub
  Dim n&: n = Cells(Rows.Count, 16).End(3).Row
  If n = 1 And IsEmpty([P1]) Then Exit Sub
  Dim col%, lig&, i&: Application.ScreenUpdating = 0
  col = 2: Do While Cells(1, col) <> "OUI" And col <= 11: col = col + 1: Loop
  If col = 12 Then Exit Sub
  lig = 2: Do While Cells(lig, 1) <> "OUI" And lig <= 12: lig = lig + 1: Loop
  If lig = 13 Then Exit Sub
  For i = 1 To n
    Cells(lig, col) = Cells(i, 16): lig = lig + 1
    If lig = 13 Then lig = 2: col = col + 1: If col = 12 Then Exit Sub
  Next i
End Sub

soan

 

[jbgaillard]

Merci beaucoup!

Ca fonctionne parfaitement

Jean-Baptiste

 

[soan]

@Jean-Baptiste

merci pour ton retour !

soan

 

[soan]

Bonsoir Jean-Baptiste,

je te propose une version améliorée du fichier précédent.

ouvre le fichier, puis fais Ctrl e ; jusqu'ici, rien de changé, n'est-ce pas ?

c'est maintenant que ça va commencer à être intéressant :

---

ne change rien sur la feuille, sélectionne H1, saisis "OUI", et valide

➯ en D1, c'est devenu "NON", sans fond jaune ; et en H1 : "OUI" est sur fond jaune

---

ne change rien sur la feuille, sélectionne A10, saisis "OUI", et valide

➯ en A5, c'est devenu "NON", sans fond jaune ; et en A10 : "OUI" est sur fond jaune

---

sans rien changer sur la grille, fais Ctrl e

➯ tu as le résultat attendu, sans avoir eu besoin d'effacer les valeurs précédentes

c'est quand même bien plus pratique, pas vrai ?

---

code VBA de Module1 :

Option Explicit

Sub Essai()
  If ActiveSheet.Name <> "Données d'entrée" Then Exit Sub
  Dim n&: n = Cells(Rows.Count, 16).End(3).Row
  If n = 1 And IsEmpty([P1]) Then Exit Sub
  Dim col%, lig&, i&: Application.ScreenUpdating = 0
  col = 2: Do While Cells(1, col) <> "OUI" And col <= 11: col = col + 1: Loop
  If col = 12 Then Exit Sub
  lig = 2: Do While Cells(lig, 1) <> "OUI" And lig <= 12: lig = lig + 1: Loop
  If lig = 13 Then Exit Sub
  [B2:K12].ClearContents
  For i = 1 To n
    Cells(lig, col) = Cells(i, 16): lig = lig + 1
    If lig = 13 Then lig = 2: col = col + 1: If col = 12 Then Exit Sub
  Next i
End Sub

seule différence par rapport à la sub précédente : ajout de : [B2:K12].ClearContents ; j'avais bêtement oublié l'effacement des valeurs précédentes ; sans ça, il peut y avoir des « interférences » entre les anciens résultats et les nouveaux, et ça t'évite de devoir effacer toi-même manuellement les anciens résultats.​

---

code VBA du module de Feuil1 :

Option Explicit

Dim plg As Range

Private Sub Job(cel As Range)
  Application.EnableEvents = 0
  plg.Value = "NON": cel = "OUI"
  Application.EnableEvents = -1
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
  With Target
    If .CountLarge > 1 Then Exit Sub
    Application.ScreenUpdating = 0
    Set plg = [A2].Resize(11)
    If Not Intersect(Target, plg) Is Nothing _
      Then If .Value = "OUI" Then Job Target
    Set plg = [B1].Resize(, 10)
    If Not Intersect(Target, plg) Is Nothing _
      Then If .Value = "OUI" Then Job Target
  End With
End Sub

---

sur la feuille de calcul, la couleur de fond jaune pour un "OUI" en B1:K1 OU en A2:A12 est mise automatiquement, par une seule règle de MFC ; rappel : MFC = Mise en Forme Conditionnelle.​

soan