Filtrer une liste par MsgBox

Le 23/11/2017 à 22:53

Bonjour,

J'ai une macro qui fabrique une liste sous forme de tableau et qui classe des personnes en fonction du code d'une activité.

Chaque personne pouvant avoir 3 activités différentes, j'avais cré 3 colonnes différentes par personne Code_1 Code_2 et Code_3.

Cette liste, reprend les coordonnées de chaque personne trois fois et y ajoute le code qu'il trouve dans les colonnes Code_X et le classe par ordre croissant. En fin, supprime le lignes de personnes ou la colonne Code est vide.

Je suppose que mon code n'est pas des meilleurs, mais je ne suis pas expert et ça fonctionne comme ça.

Tout ça pour en venir à ma question.:

Je voudrais pouvoir filtrer les codes par l'intermédiaire d'une MsgBox de manière à ne pas être obligé d'imprimer 500 noms si je n'en ai besoin que de 10.

Je ne sais pas si ce que je demande est compliqué, en tous cas merci d'avance pour vos réponses.

Voici ma macro :

'*************************************************************
'* CREATION LISTE PAR N° CODES
'**************************************************************
Sub CreeListeNoCodes()

Dim derlig
Dim n
Dim i
Dim k
Dim iNumRawDst
Dim combien
Dim FO As Worksheet, FD As Worksheet

    On Error Resume Next
    Dim shListNoCodes, shNames

    'Localise la feuille 'Liste_No_Code'
    Set shListNoCodes = Sheets("Liste_No_Codes")
    If Err.Number = 9 Then 'Si pas trouvée
        Set shListNoCodes = Sheets.Add(after:=Sheets(Sheets.Count))    'crée la feuille
        shListNoCodes.Name = "Liste_No_Codes"
    Else 'sinon
        MsgBox "La feuille 'Liste_No_Codes' existe déjà. Supprimez la et relancez la macro.", vbExclamation, "macro CreerListeNoCodes"
        Exit Sub
    End If

    If vbNo = MsgBox("La macro va créer la liste des adhérents par codes des cours. Cela prendra plusieurs secondes : " & vbCrLf & _
                     "attendez le message de fin avant de continuer à travailler avec Excel. " & vbCrLf & _
                     "Continuer ?", vbYesNo Or vbQuestion, "macro CreerListeNoCodes") Then Exit Sub

' Mise en page de l'impression
    With ActiveSheet.PageSetup
        .LeftHeader = ""
        .CenterHeader = "&06 LISTE au " & Date
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = "&06 Page &P de &N"
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0.196850393700787)
        .RightMargin = Application.InchesToPoints(0.196850393700787)
        .TopMargin = Application.InchesToPoints(0.393700787401575)
        .BottomMargin = Application.InchesToPoints(0.393700787401575)
        .HeaderMargin = Application.InchesToPoints(0.196850393700787)
        .FooterMargin = Application.InchesToPoints(0.196850393700787)
        .PrintQuality = 600
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlLandscape
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = False
    End With

   'Création Entêtes de colonnes
    With shListNoCodes.Range("A1")
        .Value = "NOM"
        .Font.Name = "Arial Narrow"
        .Font.Size = 6
        .HorizontalAlignment = xlCenter
        .ColumnWidth = 12
    End With

    With shListNoCodes.Range("B1")
        .Value = "PRENOM"
        .Font.Name = "Arial Narrow"
        .Font.Size = 6
        .HorizontalAlignment = xlCenter
        .ColumnWidth = 8
    End With

    With shListNoCodes.Range("C1")
        .Value = "H"
        .Font.Name = "Arial Narrow"
        .Font.Size = 6
        .HorizontalAlignment = xlCenter
        .ColumnWidth = 0.5
    End With

    With shListNoCodes.Range("D1")
        .Value = "F"
        .Font.Name = "Arial Narrow"
        .Font.Size = 6
        .HorizontalAlignment = xlCenter
        .ColumnWidth = 0.5
    End With

    With shListNoCodes.Range("E1")
        .Range("A1").Value = "N°"
        .Font.Name = "Arial Narrow"
        .Font.Size = 6
        .HorizontalAlignment = xlCenter
        .ColumnWidth = 5
    End With

    With shListNoCodes.Range("F1")
        .Value = "Né le"
        .Font.Name = "Arial Narrow"
        .Font.Size = 6
        .HorizontalAlignment = xlCenter
        .ColumnWidth = 8
    End With

    With shListNoCodes.Range("G1")
        .Value = "Mail"
        .Font.Name = "Arial Narrow"
        .Font.Size = 6
        .HorizontalAlignment = xlCenter
        .ColumnWidth = 21
    End With

    With shListNoCodes.Range("H1")
        .Value = "Tel_Fix"
        .Font.Name = "Arial Narrow"
        .Font.Size = 6
        .HorizontalAlignment = xlCenter
        .ColumnWidth = 9
    End With

    With shListNoCodes.Range("I1")
        .Value = "Tel.Por"
        .Font.Name = "Arial Narrow"
        .Font.Size = 6
        .HorizontalAlignment = xlCenter
        .ColumnWidth = 9
    End With

    With shListNoCodes.Range("J1")
        .Value = "Tel.Pro"
        .Font.Name = "Arial Narrow"
        .Font.Size = 6
        .HorizontalAlignment = xlCenter
        .ColumnWidth = 9
    End With

    With shListNoCodes.Range("K1")
        .Value = "Adresse"
        .Font.Name = "Arial Narrow"
        .Font.Size = 6
        .HorizontalAlignment = xlCenter
        .ColumnWidth = 19
    End With

    With shListNoCodes.Range("L1")
        .Value = "CP"
        .Font.Name = "Arial Narrow"
        .Font.Size = 6
        .HorizontalAlignment = xlCenter
        .ColumnWidth = 5
    End With

    With shListNoCodes.Range("M1")
        .Value = "Ville"
        .Font.Name = "Arial Narrow"
        .Font.Size = 6
        .HorizontalAlignment = xlCenter
        .ColumnWidth = 18
    End With

    With shListNoCodes.Range("N1")
        .Value = "Code"
        .Font.Name = "Arial Narrow"
        .Font.Size = 6
        .HorizontalAlignment = xlCenter
        .ColumnWidth = 2
    End With

'Définie des formats de colonnes spécifiques
shListNoCodes.Columns("F:F").NumberFormat = "dd/MM/yyyy"
shListNoCodes.Columns("H:J").NumberFormat = "0#"" ""##"" ""##"" ""##"" ""##"

  Set FO = Worksheets("INSCRIPTIONS_17-18") 'Définie la feuille source
  Set FD = Worksheets("Liste_No_Codes") '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 3 lignes par personnes (une pour chaque colonne de codes)
    For k = 1 To 3
      FO.Range("A" & i & ":M" & i).Copy Destination:=FD.Range("A" & n) 'Copie les 13 premières colonnes
      FD.Cells(n, 14).Value = FO.Cells(i, 13 + k).Value ' Copie le code si il y en a un
     n = n + 1
    Next 'Code suivant
  Next ' Nom suivant
'Efface les lignes n'ayant aucun code
FD.UsedRange.Columns("N").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

 'Met en forme le tableau
    ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A$1:$N$444"), , xlYes).Name = _
        "Tableau_Codes_1" ' Donne un nom au tableau créé
    Range("Tableau_Codes_1[#All]").Select ' Sélectionne la totalité du tableau
    With Selection.Font ' Définie la taille et la police pour l'ensemble du tableau
        .Name = "Arial Narrow"
        .Size = 6
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With

    With Selection.Interior ' Définie la couleur des cellules pour l'ensemble du tableau
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
        .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 = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With

    Range("Tableau_Codes_1[#Headers]").Select 'Sélectionne les entêtes de colonnes
    With Selection.Font
        .ColorIndex = xlAutomatic 'Met la police en noir
        .TintAndShade = 0
    End With

  'Trie le tableau par N° de code puis par nom et en fin par prénom
    ActiveWorkbook.Worksheets("Liste_No_Codes").ListObjects("Tableau_Codes_1").Sort. _
        SortFields.Clear
    ActiveWorkbook.Worksheets("Liste_No_Codes").ListObjects("Tableau_Codes_1").Sort. _
        SortFields.Add Key:=Range("Tableau_Codes_1[Code]"), SortOn:=xlSortOnValues, Order _
        :=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Liste_No_Codes").ListObjects("Tableau_Codes_1").Sort. _
        SortFields.Add Key:=Range("Tableau_Codes_1[NOM]"), SortOn:=xlSortOnValues, Order _
        :=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Liste_No_Codes").ListObjects("Tableau_Codes_1").Sort. _
        SortFields.Add Key:=Range("Tableau_Codes_1[PRENOM]"), SortOn:=xlSortOnValues, _
        Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Liste_No_Codes").ListObjects("Tableau_Codes_1").Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

  shListNoCodes.Activate
   With ActiveWindow
        .SplitColumn = 0
        .SplitRow = 1
   End With

    ActiveWindow.FreezePanes = True

Range("A2").Select

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

Sheets("TABLEAU_DE_BORD").Select
    Cells(16, 29).Value = 1
    Cells(16, 31).Font.Size = 8
    Cells(16, 31).Font.Bold = False
    Cells(16, 31).Value = "  Liste créée le " & Date & " à " & Time
    Cells(1, 1).Select
    Cells(1, 1).Activate

Sheets("Liste_No_Codes").Select
    If vbNo = MsgBox("Liste correctement créée. " & iNumRawDst - 1 & " lignes ajoutées." & vbCrLf & "La feuille est concue pour " & _
           "être imprimée sur du papier A4 en mode paysage. Voulez-vous l'imprimer ?", vbYesNo Or vbQuestion, "macro CreerListeNoCodes") Then Exit Sub Else ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True

End Sub
Le 24/11/2017 à 02:19

Bonjour,

Soit tu trouves ton bonheur dans les sujets similaires en bas de cette page, soit tu nous mets ton fichier anonymisé

A+

Le 24/11/2017 à 10:51

Bonjour et merci pour votre aide.

J'ai joint mon fichier auquel j'ai supprimé plusieurs feuilles inutiles pour mon problème.

La macro existante qui se trouve en fin du Module "ModuListe" se lance en cliquant sur le bouton "Création liste des adhérents par codes discipline" sur la feuille "TABLEAU_DE_BORD"

Encore merci

15essai.xlsm (309.29 Ko)
Rechercher des sujets similaires à "filtrer liste msgbox"