Modification d'une macro.

Version imprimable

Bonjour,
J'ai une macro qui me permet de copier sur une "feuille 2" par ordre alphabétique et sur une seule colonne toutes les données d'une autre "feuille 1".
J'aimerais pouvoir copier certaines données en spécifiant des mots clés ( par exemple : poulet; filet; cuisses) dans une autre "feuille 3" avec le même système, les données de la "feuille 1".
Que faut-il que je rajoute, dans ma macro pour arriver à avoir sur la "feuille 3" par ordre alphabétique et sur une seule colonne toutes les données qui correspondent à poulet; filet; cuisses ?
Merci pour votre aide. ;)

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
Option Explicit
Sub Au_menu()
Dim c As Range
With Application: .ScreenUpdating = False: .Calculation = xlManual: .EnableEvents = False: End With
Sheets("LISTE TOTAL MIDI").Cells.Clear
Range("midi").Copy Destination:=Sheets("LISTE TOTAL MIDI").Range("a1")
Sheets("LISTE TOTAL MIDI").Activate
Columns("A:F").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
Range(Range("b1"), Range("b1").End(xlDown)).Cut Destination:=Range("a65536").End(3)(2)
Range(Range("c1"), Range("c1").End(xlDown)).Cut Destination:=Range("a65536").End(3)(2)
Range(Range("d1"), Range("d1").End(xlDown)).Cut Destination:=Range("a65536").End(3)(2)
Range(Range("e1"), Range("e1").End(xlDown)).Cut Destination:=Range("a65536").End(3)(2)
Range(Range("f1"), Range("f1").End(xlDown)).Cut Destination:=Range("a65536").End(3)(2)
Columns("A:A").SpecialCells(xlCellTypeConstants, 23).Value = Application.Trim(Columns("A:A").SpecialCells(xlCellTypeConstants, 23).Value)
With Range("A:A")
    .Sort Range("A1"), xlAscending, Header:=xlNo
    .Font.Size = 10
    .WrapText = False
    .EntireColumn.AutoFit
    .HorizontalAlignment = xlLeft
End With
Sheets("LISTE TOTAL SOIR").Cells.Clear
Range("soir").Copy Destination:=Sheets("LISTE TOTAL SOIR").Range("a1")
Sheets("LISTE TOTAL SOIR").Activate
Columns("A:F").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
Range(Range("b1"), Range("b1").End(xlDown)).Cut Destination:=Range("a65536").End(3)(2)
Range(Range("c1"), Range("c1").End(xlDown)).Cut Destination:=Range("a65536").End(3)(2)
Range(Range("d1"), Range("d1").End(xlDown)).Cut Destination:=Range("a65536").End(3)(2)
Range(Range("e1"), Range("e1").End(xlDown)).Cut Destination:=Range("a65536").End(3)(2)
Range(Range("f1"), Range("f1").End(xlDown)).Cut Destination:=Range("a65536").End(3)(2)
Columns("A:A").SpecialCells(xlCellTypeConstants, 23).Value = Application.Trim(Columns("A:A").SpecialCells(xlCellTypeConstants, 23).Value)
With Range("A:A")
    .Sort Range("A1"), xlAscending, Header:=xlNo
    .Font.Size = 10
    .WrapText = False
    .EntireColumn.AutoFit
    .HorizontalAlignment = xlLeft
End With
With Application: .EnableEvents = True: .Calculation = xlAutomatic: .ScreenUpdating = True: End With
End Sub

1 pièce(s) jointe(s)

Bonjour,
Il semble que ce soit une exportation sous condition. Pour cela, j'utilise la méthode AdvancedFilter

Voici un exemple de procédure qui exporte les lignes de la colonne nommée Libellé si la valeur contenue dans la colonne Rayon contient l'un des trois éléments que l'on retrouve dans la plage nommée areaCriteria (plage M1:M4). L'exportation a lieu dans une nouvelle feuille

La source de données est un tableau structuré qui est seul dans la feuille dont la propriété CodeName est shtData

Code de la procédure
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 Sub T() ' Déclarartion Const Label2Export As String = "Libellé" ' Etiquette de la colonne à exporter Dim oList As ListObject Dim rngSource As Range Dim rngTarget As Range ' Assignation Set oList = shtData.ListObjects(1) Set rngSource = oList.Range With rngSource ' Enlève une ligne à l'objet rngSource si la propriété ShowTotals de l'objet oLst est égal à True Set rngSource = .Resize(.Rows.Count - Abs(oList.ShowTotals)) End With ' Start Process ThisWorkbook.Worksheets.Add ' Insère une feuille Set rngTarget = ActiveSheet.Cells(1, 1) ' Référencement à la Feuille cible rngTarget.Value = Label2Export ' Ecrit l'étiquette de colonne ' Exportation suivant critères rngSource.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range("areaCriteria"), CopyToRange:=rngTarget ' ici le tri ' EndOfProcess Set oList = Nothing: Set rngSource = Nothing: Set rngTarget = Nothing End Sub
Illustration
Pièce jointe 560056

Liens pour en savoir plus sur

Les tableaux structurés
Les filtres avancés d'excel (AdvancedFilter)
La propriété CodeName d'une feuille

26/04/2020, 13h05
DAVIDSAVOIE

Merci pour ton aide.

Bonjour Philippe Tulliez,
Merci beaucoup pour ta solution, mais étant novice, je n'arrive pas a utiliser le code.
Cordialement.
David.