XL 2019 Importation de listes à deux conditions

JR.31

XLDnaute Occasionnel
Bonjour à toutes et tous,
Voilà, je bloque sur un problème.
J'aimerais faire:
1)- Une importation de liste avec deux conditions,
2)- Ajuster la page au nombre de lignes de la liste importée,
3)- faire une bouton pour enregistrer cette feuille sur une nouvelle qui porterais le nom des deux cellules de recherche.
Ci joint le classeur pour exemple.

Merci à toutes et tous de pouvoir m'aider.

JR.31
 

Pièces jointes

  • Eleves Essai.xlsm
    38.7 KB · Affichages: 7

AtTheOne

XLDnaute Accro
Supporter XLD
Bonne nuit les noctambules, bonjour @JR.31

  • J'ai dû reprendre quelques détails de la Base de Données (concernant la liste des noms d'écoles) et de la feuille EVALUATION EACE-T (essentiellement les formules)
  • J'ai ajouté 7 noms définis (ils commencent par "_")
  • J'ai attribué les CodeName F01_BdD à la feuille "BASE DE DONNEES" et F02_Eval à la feuille "EVALUATION EACE-T".
  • J'ai créé le module VBA M01 avec 2 macros :
ExtraireListeElèves
Enrichi (BBcode):
Sub ExtraireListeElèves()
    Dim C2 As Range 'Etablissement
    Dim E2 As Range 'Professeur
    Dim C4 As Range 'Début liste d'élèves
  
    Dim LigneT As Range, Ecole As Range, Tableau, Tb_Élèves()
    Dim k As Integer, i As Integer, NbLgns, NbCols
  
    Set C2 = F02_Eval.[C2]: Set E2 = F02_Eval.[E2]: Set C4 = F02_Eval.[C4]
    'Nettoyage de la zone cible
    F02_Eval.[_Liste].ClearContents
    NbLgns = F02_Eval.[_Liste].Rows.Count
    If NbLgns > 1 Then F02_Eval.[C4].Offset(1).Resize(F02_Eval.[_Liste].Rows.Count - 1).EntireRow.Delete
    If C2 = "" Or E2 = "" Then Exit Sub
  
    'Ligne de titre de la BdD
    With F01_BdD.Rows(2): Set LigneT = .Resize(1, .Columns(.Columns.Count).End(xlToLeft).Column): End With
    With LigneT: NbCols = .Cells.Count + .Cells(.Cells.Count).MergeArea.Columns.Count - 1: End With
    Set LigneT = LigneT.Resize(1, NbCols)
  
    'Plage concernant l'école
    Set Ecole = Nothing
    Set Ecole = LigneT.Find(What:=Replace(C2, "_", " "), after:=LigneT.Cells(1), LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlPrevious)
    If Ecole Is Nothing Then Exit Sub
  
    'nombre de colonnes et de lignes de la zone de l'établissement
    NbCols = Ecole.MergeArea.Columns.Count
    With Ecole.EntireColumn: NbLgns = .Cells(.Rows.Count).End(xlUp).Row - Ecole.Row + 1: End With
  
    'Récupération des données de la zone établissement dans un tableau
    Tableau = Ecole.Resize(NbLgns, NbCols)
    k = 0
    i = 1
    'recherche de la ligne "ELEVES"
    Do While Tableau(i, 1) <> "ELEVES"
         i = i + 1
         If i = NbLgns Then Exit Do
    Loop
    If Tableau(i, 1) <> "ELEVES" Or i = NbLgns Then Exit Sub
  
    'recherche de la ligne du professeur
    Do While Tableau(i, 1) <> E2
         i = i + 1
         If i = NbLgns Then Exit Do
    Loop
    If Tableau(i, 1) <> E2 Or i = NbLgns Then Exit Sub
  
    'enregistrement de la liste des élèves
    i = i + 1
    Do While Tableau(i, 2) <> ""
         k = k + 1: ReDim Preserve Tb_Élèves(1 To k): Tb_Élèves(k) = Tableau(i, 1): i = i + 1
         If i > NbLgns Then Exit Do
    Loop
    If k = 0 Then Exit Sub
  
    'ajout des lignes nécessaires
    C4.Offset(1).Resize(k - 1).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    'Copie de la liste des élèves
    C4.Resize(k).Value = WorksheetFunction.Transpose(Tb_Élèves)
  
End Sub

Créer_Feuille
Enrichi (BBcode):
Sub Créer_Feuille()
    Dim C2 As Range 'Etablissement
    Dim E2 As Range 'Professeur
    Dim NomFeuille As String, Wsh As Worksheet, Nom As Name
  
  
    Set C2 = F02_Eval.[C2]: Set E2 = F02_Eval.[E2]
    'si au moins une des cellules Etablissement, Professeur est vide sortir
    If C2 = "" Or E2 = "" Then Exit Sub
  
    'Nom de la feuille à créer
    NomFeuille = Left(Replace(C2, "_", " ") & " - " & E2, 31)
  
    'Vérifier que la feuille n'existe pas déjà
    Set Wsh = Nothing
    On Error Resume Next
    Set Wsh = ThisWorkbook.Worksheets(NomFeuille)
    On Error GoTo 0
    If Not Wsh Is Nothing Then MsgBox Title:="Création " & NomFeuille, Prompt:="La feuille " & NomFeuille & " existe déjà !" & Chr(10) & "Abandon", Buttons:=vbCritical: Exit Sub
  
    'Copie vers la feuille "NomFeuille"
    F02_Eval.Copy after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
    Set Wsh = ActiveSheet
    Wsh.Name = NomFeuille
  
    'Remplacer les formules par leur valeur
    Wsh.UsedRange.Value = Wsh.UsedRange.Value
  
    'Supprimer les validations des cellules Etablissement et Professeur
    Wsh.[C2,E2].Validation.Delete
    'Effacer le bouton d'appel de la macro
    Wsh.Shapes("_Bt_Créer_Feuille").Delete
    'Effacer le texte du bouton d'appel
    Wsh.[_Texte_Bouton_Créer].Clear
    'Supprimer les noms sauf la zone d'impression
    For Each Nom In Wsh.Names
        If Not Nom.NameLocal Like "*Zone_d_impression" Then Nom.Delete
    Next
  
End Sub

J'ai ajouter la gestion de l'événement Change de la feuille "EVALUATION EACE-T"
Enrichi (BBcode):
Private Sub Worksheet_Change(ByVal Target As Range)
  
    If Target.Cells(1).Address <> Me.[_Etablissement].Address And Target.Cells(1).Address <> Me.[_Professeur].Address Then Exit Sub
  
    Application.EnableEvents = False
    ExtraireListeElèves
    Application.EnableEvents = True
      
End Sub

Voir le fichier joint
Amicalement
Alain
 

Pièces jointes

  • Eleves Essai.xlsm
    47.9 KB · Affichages: 4
Dernière édition:

JR.31

XLDnaute Occasionnel
Bonjour Alain,
Merci pour ton aide, mais je ne peux pas ouvrir le fichier, un message qui me dis qu'il y à une erreur, et quant je répare, plus aucunes macro qui fonctionnent.
A tu une idée?
Cordialement
Jacques
 

AtTheOne

XLDnaute Accro
Supporter XLD
Bonjour à toute & à tous, bonjour @JR.31

Oui Jacques, c'est possible j'ai ajouté ces lignes à la macro "Créer_Feuille()"
Enrichi (BBcode):
  ...   
     Wsh.ExportAsFixedFormat Type:=xlTypePDF, _
                             Filename:=ThisWorkbook.Path & "\" & Wsh.Name & ".pdf", _
                             IgnorePrintAreas:=False, OpenAfterPublish:=False
...

Le pdf de la feuille est créé sous le même répertoire que le classeur.

Amicalement
Alain
 

Pièces jointes

  • EVALUATION Elèves.xlsm
    47.6 KB · Affichages: 2

Discussions similaires

Membres actuellement en ligne

Aucun membre en ligne actuellement.

Statistiques des forums

Discussions
312 827
Messages
2 092 557
Membres
105 451
dernier inscrit
mariane_lp