Compter le nombre de participants à une activité dans une liste

Question

Bonjour.

J'ai un programme sous Excel 2019 avec Windows 10 me permettant de gérer une toute petite association qui débute depuis 2 ans. Cette association propose une douzaines d'activités dont les personnes inscrites peuvent en sélectionner de 1 à 4 au maximum pour l'année.

Le code joint crée une liste de 4 lignes par inscrit et supprime les lignes où aucune activité n'est mentionnée puis classe la liste par ordre alphabétique des activités. Le code n'est sans doute pas très académique car je ne suis qu'un petit amateur de bas niveau, mais il fonctionne. Il me donne une liste des personnes inscrites par activité. Mon problème, c'est qu'à chaque impression de cette liste, il faut que je compte le nombre de participants pour chaque activité. Je ne sais pas si ce que je demande est faisable, mais je voudrais que ma liste comprenne un champ suplémentaire m'indiquant à la dernière ligne de chaque activité, le nombre de participants pour cette activité.

Merci d'avance si vous trouvez une solution à mon problème.

La base de données comprend les champs suivants et se nomme "INSCRIPTIONS_" & ChoixAnnee .

ChoixAnnee est renseigné sur la feuil TABLEAU_DE_BORD en G6 et correspond aux 4 chiffres de l'année en cours.

NOM	PRENOM	N°_ADHERENT	H	F	NE_LE	MAIL	TEL_FIX	TEL_POR	ADRESSE	CP	VILLE	ACTIVITE_1	ACTIVITE_2	ACTIVITE_3	ACTIVITE_4	COTISATION	DATE_INS	COMMENTAIRES	AGE	QUALITE	PAIEMENT

Le code concernant la liste est le suivant :

'*************************************************************

'* CREATION LISTE PAR ATELIERS

'**************************************************************

---

Sub LISTE_PAR_ATELIERS()

Dim x As Integer, pctComp1 As Single

Dim derlig

Dim N

Dim i

Dim k

Dim z

Dim iNumRawDst

Dim combien

Dim FO As Worksheet, FD As Worksheet

Dim LigneF

Dim rng As Range

Dim InputRng As Range

Dim DeleteRng As Range

Dim DeleteStr As String

Dim Counter As Integer

Dim PctDone As Single

Dim f As Worksheet

Dim shListAteliers, shNames

Dim LiTab

On Error Resume Next

Sheets("TABLEAU_DE_BORD").Activate

ChoixAnnee = Sheets("TABLEAU_DE_BORD").Range("G6")

'Localise la feuille 'Liste_ParAteliers'

Set f = Sheets("Liste\_ParAteliers\_" & ChoixAnnee) 

If Err.Number = 9 Then **'Si pas trouvée** 

    Set f = Sheets.Add(after:=Sheets(Sheets.Count))    **'crée la feuille** 

    f.Name = "Liste\_ParAteliers\_" & ChoixAnnee 

Else **'sinon** 

    MsgBox "La feuille 'Liste\_ParAteliers\_" & ChoixAnnee & \_ 

    "' existe déjà. Supprimez-la et relancez la macro.", vbExclamation, "macro ListeParAteliers": UserForm1.Hide: Unload UserForm1 

    Exit Sub 

End If 

If vbNo = MsgBox("La macro va créer la liste des adhérents par ateliers. Cela prendra plusieurs minutes : " & vbCrLf & \_ 

                 "attendez le message de fin avant de continuer à travailler avec Excel. " & vbCrLf & \_ 

                 "Continuer ?", vbYesNo Or vbQuestion, "macro Liste\_ParAteliers") Then Sheets("Liste\_ParAteliers\_" & ChoixAnnee).Select: \_ 

                 ActiveWindow.SelectedSheets.Delete: Sheets("TABLEAU\_DE\_BORD").Select: Exit Sub 

f.Range("I10").Value = "PATIENTEZ JUSQU'A L'APPARITION DU TABLEAU ..."

f.Range("I11").Value = ""

Application.ScreenUpdating = False

'Création Entêtes de colonnes

f.Range("A1").Value = "NOM" 

f.Range("B1").Value = "PRENOM" 

f.Range("C1").Value = "N°" 

f.Range("D1").Value = "H" 

f.Range("E1").Value = "F" 

f.Range("F1").Value = "Né le" 

f.Range("G1").Value = "Mail" 

f.Range("H1").Value = "Tel.Fix" 

f.Range("I1").Value = "Tel.Mob" 

f.Range("J1").Value = "Adresse" 

f.Range("K1").Value = "CP" 

f.Range("L1").Value = "Ville" 

f.Range("M1").Value = "Activité" 

'Définie des formats de colonnes spécifiques

f.Columns("F:F").NumberFormat = "dd/MM/yyyy"

f.Columns("H:I").NumberFormat = "0#"" ""##"" ""##"" ""##"" ""##"

Set FO = Worksheets("INSCRIPTIONS_" & ChoixAnnee) 'Définie la feuille source

Set FD = Worksheets("Liste_ParAteliers_" & ChoixAnnee) 'Définie la feuille destination

derlig = FO.Range("A" & Rows.Count).End(xlUp).Row 'Définie la dernière ligne

 N = 2 

For i = 2 To derlig

combien = Cells(i, Columns.Count).End(xlToLeft).Column - 13 '**Définie le Nb. de colonnes à copier par lignes** 

**'Crée 4 lignes par personnes (une pour chaque colonne d'activité)** 

For k = 1 To 4

FO.Range("A" & i & ":M" & i).Copy Destination:=FD.Range("A" & N) '**Copie les 13 premières colonnes** 

FD.Cells(N, 13).Value = FO.Cells(i, 12 + k).Value ' **Copie l'activité si il y en a une** 

FD.Cells(N, 13).Select 

If FD.Cells(N, 13).Value = "-" Then FD.Cells(N, 13).EntireRow.Delete 

N = N + 1 

Next k 'Activité suivante

Next i ' Nom suivant

For z = Sheets("Liste_ParAteliers_" & ChoixAnnee).Range("A1000").End(xlUp).Row To 1 Step -1

If Application.CountA(Rows(z)) = 0 Then Rows(z).Delete Shift:=xlUp

Next

shListAteliers.Activate

iNumRawDst = Application.WorksheetFunction.CountA(shListAteliers.Range("A:A"))

derlig = Range("A1000").End(xlUp).Row

' Met le tableau en forme

ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A$1:$M$" & derlig), , xlYes).Name = "TableauAteliers"

Sheets("Liste_ParAteliers_" & ChoixAnnee).Range("TableauAteliers[#All]").Select

With Selection.Font ' Définie la taille et la police pour l'ensemble du tableau

.Name = "Arial Narrow" 

.Size = 8 

.Color = &H80000012 

.Strikethrough = False 

.Superscript = False 

.Subscript = False 

.OutlineFont = False 

.Shadow = False 

.TintAndShade = 0 

.ThemeFont = xlThemeFontNone 

End With

With Selection.Interior ' Met la couleur des cellules à 0 pour l'ensemble du tableau

.PatternColorIndex = 0 

.ThemeColor = 0 

.TintAndShade = 0 

.PatternTintAndShade = 0 

End With

Selection.Borders(xlEdgeRight).LineStyle = xlNone 'Trace un trait entre chaque ligne du tableau

With Selection.Borders(xlInsideHorizontal)

.LineStyle = xlContinuous 

.ColorIndex = 1 

.TintAndShade = 0 

.Weight = xlThin 

End With

ActiveSheet.ListObjects("TableauAteliers").TableStyle = "TableStyleMedium2"

Range("TableauAteliers[[#Headers],[Ateliers]]").Select 'Met en forme le tableau au style Médium 2

With ActiveWindow ' Fige la ligne des entêtes

.SplitColumn = 0 

.SplitRow = 1 

.a 

End With

' Trie le tableau par ordre alphabétique des ateliers

ActiveWorkbook.Worksheets("Liste_ParAteliers_" & ChoixAnnee).ListObjects( _

    "TableauAteliers").Sort.SortFields.Clear 

ActiveWorkbook.Worksheets("Liste_ParAteliers_" & ChoixAnnee).ListObjects( _

    "TableauAteliers").Sort.SortFields.Add2 Key:=Range( \_ 

    "TableauAteliers[[#All],[Ateliers]]"), SortOn:=xlSortOnValues, Order:= \_ 

    xlAscending, DataOption:=xlSortNormal 

With ActiveWorkbook.Worksheets("Liste_ParAteliers_" & ChoixAnnee).ListObjects( _

    "TableauAteliers").Sort 

    .Header = xlYes 

    .MatchCase = False 

    .Orientation = xlTopToBottom 

    .SortMethod = xlPinYin 

    .Apply 

End With

Dim FIN

FIN = Range("A2000").End(xlUp).Row

Range("A1:M" & FIN).EntireRow.AutoFit

Range("A1:M" & FIN).Columns.AutoFit

Range("A1").Select

Sheets("TABLEAU_DE_BORD").Select

Cells(9, 29).Value = 1 

Cells(9, 31).Font.Size = 8 

Cells(9, 31).Font.Bold = False 

Cells(9, 31).Value = "  Liste " & ChoixAnnee & " du " & Date 

Cells(1, 1).Select 

Cells(1, 1).Activate 

Sheets("Liste_ParAteliers_" & ChoixAnnee).Visible = True

Sheets("Liste_ParAteliers_" & ChoixAnnee).Select

Application.ScreenUpdating = True

If vbNo = MsgBox("Liste correctement créée. " & FIN - 1 & " lignes ajoutées." & vbCrLf & "La feuille est concue pour " & _

       "être imprimée sur du papier A4 en portrait. Voulez-vous l'imprimer ?", vbYesNo Or vbQuestion, "macro CreerListeNoCodes") \_ 

       Then Exit Sub Else 

With ActiveSheet.PageSetup 

    .LeftHeader = "" 

    .CenterHeader = "Feuille Liste\_ParAteliers\_" & ChoixAnnee & " au &D à &T" 

    .RightHeader = "" 

    .LeftFooter = "" 

    .CenterFooter = "Page &P de &N" 

    .RightFooter = "" 

    .Orientation = xlPortrait 'xlLandscape 

    .PaperSize = xlPaperA4 

    .HeaderMargin = Application.CentimetersToPoints(1) 

    .FooterMargin = Application.CentimetersToPoints(1) 

    .TopMargin = Application.CentimetersToPoints(1.5) 

    .BottomMargin = Application.CentimetersToPoints(1.5) 

    .RightMargin = Application.CentimetersToPoints(1) 

    .LeftMargin = Application.CentimetersToPoints(1) 

    .PrintTitleRows = "$1:$1" 

    .Zoom = False 

    .FitToPagesWide = 1 

    .FitToPagesTall = 0 

End With 

ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True

End Sub

Answer 1

Bonjour.

C'est absolument parfait.

Merci beaucoup

Answer 2

Essaie :

https://www.cjoint.com/c/MADlnV0yNl6

Daniel

Answer 3

Suite à votre mail, je vous joint le lien pour le programme:

https://www.cjoint.com/c/MADjCbKC3Tq

Merci

Answer 4

Ca serait bien aussi d'avoir la liste des activités, si elle n'est pas dans le classeur.

Daniel

Answer 5

Bonjour,

Partage le fichier en modifiant les noms. On ne peut rien faire sans avoir une idée de la disposition des données. Pour le partager, clique sur :

https://www.cjoint.com/

Clique sur le bouton "parcourir". Choisis le fichier à partager. Dans le bas de la page, clique sur le bouton "Créer le lien cjoint". Copie le lien affiché et colle-le dans ta réponse.

Daniel