Listes automatiques sous critères à partir de plusieurs onglets

Jamie0d9 · 9 Février 2017

Bonjour,

J'ai longtemps cherché sur le forum mais je n'arrive pas à trouver chaussure à mon problème.

J'ai un fichier excel dans lequel sur plusieurs onglets (un par classe) les participants à divers ateliers.

J'aimerais si possible regrouper dans un onglet via sélection sur liste déroulante (si possible) les participants par activité.
Les listes devront par la suite servir au pointage des présences (partie facile que je n'ai pas eu grand mal à réaliser).

pour faire simple : lister automatiquement tous les participants à tel atelier présents dans chaque onglet.

Je joint un fichier qui illustre un peu ce que je souhaiterait obtenir.

Merci d'avance à tous ceux qui prendront le temps de me lire et d'étudier ma problématique.

job75 · 9 Février 2017

Bonsoir Jamie0d9, bienvenue sur XLD,

Pour un 1er post c'est un problème costaud et qui tient bien la route, bravo.

Votre fichier en retour avec cette macro paramétrée :

Code:

Option Explicit
Option Compare Text 'la casse est ignorée (sécurité)

Sub Liste(cible$, dest As Range)
Dim nlig&, w As Worksheet, nf$, i&, n, a$(), x$, flag As Boolean, j&
nlig = dest.Rows.Count
'---liste de tous les noms/classes---
For Each w In Worksheets
  nf = w.Name
  If Val(nf) Then 'onglets commençant par un chiffre
    For i = 2 To w.[A1].CurrentRegion.Rows.Count
      If w.Cells(i, 3) = cible Then
        n = n + 1
        ReDim Preserve a(1 To 3, 1 To n)
        a(1, n) = w.Cells(i, 1)
        a(2, n) = nf
      End If
    Next i
  End If
Next w
'---repérage des noms/classes déjà inscrits et effacement des autres---
For i = 1 To nlig
  x = dest(i, 1) & dest(i, 2)
  flag = False
  If x <> "" Then
    For j = 1 To n
      If a(1, j) & a(2, j) = x Then a(3, j) = "x": flag = True
    Next j
    If Not flag Then dest(i, 1).Resize(, 5) = ""
  End If
Next i
'---inscription du reste sur les lignes vides---
For j = 1 To n
  If a(3, j) = "" Then
    flag = False
    For i = 1 To nlig
      If dest(i, 1) & dest(i, 2) = "" Then
        dest(i, 1) = a(1, j)
        dest(i, 2) = a(2, j)
        flag = True
        Exit For
      End If
    Next i
    If Not flag Then MsgBox "Zone à remplir insuffisante !", 48: Exit Sub
  End If
Next j
End Sub

Elle est appelée par les macros Worksheet_Change (feuille "regroupe") et Worksheet_Activate (feuilles "Badmington" et "Echecs").

A+

Jamie0d9 · 9 Février 2017

Bonjour job75,

merci beaucoup pour ce que tu as fait, c'est exactement ce que je souhaite réaliser, je n'y connais pas grand chose en macros donc j'aimerais comprendre un peu le fonctionnement pour l'adapter en connaissance de cause à mon fichier d'origine.

Pourrais-tu m'expliquer le rôle des feuilles "badmington" et "echecs" et le mode de remplissage, je n'en ai que deux mais dans "regroup" j'arrive à voir la sélection faite pour les autres activités.

Quand tu as dit d'activer ces deux onglets je pensais qu'au final je devrais avoir autant d'onglet qu'il y a d'activité.

je tente d'adapter ton travail à mon fichier d'origine mais le résultat n'est pas au rendez-vous comme dans le fichier que tu m'as transmis

job75 · 10 Février 2017

Bonsoir Jamie0d9, le forum,

Il manquait pas mal de choses avec ma solution précédente.

Voyez ce fichier (2) et les nouveaux codes.

Dans la feuille Regroupe :

Code:

Private Sub Worksheet_Activate()
Worksheet_Change [B1] 'lance cette macro
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> "$B$1" Then Exit Sub
Application.ScreenUpdating = False
With [A4:E12] 'plage à adapter éventuellement
  .ClearContents
  On Error Resume Next 'si la feuille n'existe pas
  Liste Sheets(CStr(Target))
  .Value = Sheets(CStr(Target)).[A2:E10].Value 'plage à adapter éventuellement
End With
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Address <> "$B$1" Then Exit Sub
Cancel = True
On Error Resume Next 'si la feuille n'existe pas
Sheets(CStr([B1])).Activate
End Sub

Dans ThisWorkbook :

Code:

Private Sub Workbook_Open()
Me.Saved = True 'évite l'invite à la fermeture si aucune modification
End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
If Application.CountIf(Sheets("Liste des ateliers").[B:B], Sh.Name) Then Liste Sh
End Sub

Dans Module1 :

Code:

Option Compare Text 'la casse est ignorée (sécurité)

Sub Feuille_regroupe()
'se lance par Ctrl+R
Sheets("Regroupe").Activate
End Sub

Sub Liste(w As Worksheet)
Dim dest As Range, nlig&, cible$, nf$, i&, n, a(), x$, flag As Boolean, j&
Set dest = w.[A2:E10] 'plage à remplir, à adapter éventuellement
nlig = dest.Rows.Count
cible = w.Name
'---liste de tous les noms/classes---
For Each w In Worksheets
  nf = w.Name
  If Val(nf) Then 'nom de la feuille commençant par un chiffre
    For i = 2 To w.[A1].CurrentRegion.Rows.Count
      If w.Cells(i, 3) = cible Then
        n = n + 1
        ReDim Preserve a(1 To 3, 1 To n)
        a(1, n) = w.Cells(i, 1)
        a(2, n) = nf
      End If
    Next i
  End If
Next w
'---repérage des noms/classes déjà inscrits et effacement des autres---
For i = 1 To nlig
  x = dest(i, 1) & dest(i, 2)
  flag = False
  If x <> "" Then
    For j = 1 To n
      If a(1, j) & a(2, j) = x Then a(3, j) = "x": flag = True
    Next j
    If Not flag Then dest(i, 1).Resize(, 5) = ""
  End If
Next i
'---inscription du reste sur les lignes vides---
For j = 1 To n
  If a(3, j) = "" Then
    flag = False
    For i = 1 To nlig
      If dest(i, 1) & dest(i, 2) = "" Then
        dest(i, 1) = a(1, j)
        dest(i, 2) = a(2, j)
        dest(i, 3).Resize(, 3) = ""
        flag = True
        Exit For
      End If
    Next i
    If Not flag Then MsgBox "Zone à remplir insuffisante !", 48: Exit For
  End If
Next j
dest.Sort dest(1), xlAscending, Header:=xlNo 'tri pour regrouper en cas de lignes vides
End Sub

A+

Jamie0d9 · 13 Février 2017

Bonjour job75

Encore merci pour ton aide très précieuse.
J'ai pris le week-end pour comprendre les codes, mais au final j'ai compris le cheminement et la manière dont il se met en oeuvre.

Je ne pourrais peut-être pas faire aussi complexe mais j'ai définitivement compris la logique.

Milles mercis

Jamie0d9 · 3 Mars 2017

Bonjour job75,

J'aimerais savoir s'il est possible de permettre à un individu N d'être présent dans plusieurs ateliers.
la aussi les conditions de remplissage seraient les mêmes que précédemment, mais cet individu serait présent lors de la ventilation automatique sur plusieurs onglets.

job75 · 3 Mars 2017

Bonjour Jamie0d9,

Aucun problème, dans la macro Liste il suffit de remplacer :

Code:

      If w.Cells(i, 3) = cible Then

par :

Code:

      If Application.CountIf(w.Cells(i, 3).Resize(, 3), cible) Then '3 ateliers possibles

Attention, dans la liste des ateliers il y avait un espace superflu après le mot "Chant", je l'ai enlevé !

Fichier (3).

A+

Jamie0d9 · 6 Mars 2017

Bonjour Job75

Merci encore pour ton aide.

Il m'avait été proposé de rajouter une boucle pour prendre en compte les 3 activités mais ta solution fonctionne parfaitement.

boucle :

Code:

For iActivite = 3 To 5

job75 · 6 Mars 2017

Bonsoir Jamie0d9,

Jamie0d9 à dit:
Il m'avait été proposé de rajouter une boucle pour prendre en compte les 3 activités

Une boucle pour analyser chacune des 3 cellules c'est besogneux.

Il est alors plus simple d'utiliser, très classiquement :

Code:

If w.Cells(i, 3) = cible Or w.Cells(i, 4) = cible Or w.Cells(i, 5) = cible Then

Bonne fin de soirée.

Listes automatiques sous critères à partir de plusieurs onglets

Jamie0d9

XLDnaute Nouveau

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

Jamie0d9

XLDnaute Nouveau

job75

XLDnaute Barbatruc

Pièces jointes

Jamie0d9

XLDnaute Nouveau

Jamie0d9

XLDnaute Nouveau

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

Jamie0d9

XLDnaute Nouveau

job75

XLDnaute Barbatruc

Discussions similaires