Macro pour filtrer dans une base

Version imprimable

Bonjour,

J'essaie de réaliser une macro qui permet de filtrer dans une base selon 1 critèrepuis copier-coller les données trouvées avec le critère sélectionné.

Par exemple :
Sélectionner Dpt. Rhône Alpes
Copier les lignes qui correspondent au département Rhône-Alpes
Coller les lignes dans une nouvelle feuille.

J'ai essayé l'enregistreur de macro mais cela marche seulement avec le premier critère sélectionné. Or, j'ai plusieurs critères à faire.

Voici le code obtenu :
Merci d'avance 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
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
Sub Macro1()
'
' Macro1 Macro
'
 
'
    ActiveSheet.Range("$A$1:$AI$120334").AutoFilter Field:=35, Criteria1:="DIR1"
    ActiveWindow.ScrollColumn = 19
    ActiveWindow.ScrollColumn = 18
    ActiveWindow.ScrollColumn = 15
    ActiveWindow.ScrollColumn = 12
    ActiveWindow.ScrollColumn = 9
    ActiveWindow.ScrollColumn = 3
    ActiveWindow.ScrollColumn = 1
    Range("A1:B1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Paste
    Sheets("Feuil2").Select
    Range("K743").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "1"
    ActiveSheet.Range("$A$1:$AI$120334").AutoFilter Field:=35, Criteria1:="DIR2"
    ActiveWindow.ScrollColumn = 20
    ActiveWindow.ScrollColumn = 19
    ActiveWindow.ScrollColumn = 17
    ActiveWindow.ScrollColumn = 15
    ActiveWindow.ScrollColumn = 10
    ActiveWindow.ScrollColumn = 1
    Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Paste
    ActiveWindow.ScrollColumn = 2
    ActiveWindow.ScrollColumn = 3
    ActiveWindow.ScrollColumn = 4
    ActiveWindow.ScrollColumn = 5
    ActiveWindow.ScrollColumn = 7
    ActiveWindow.ScrollColumn = 9
    ActiveWindow.ScrollColumn = 11
    ActiveWindow.ScrollColumn = 13
    ActiveWindow.ScrollColumn = 16
    ActiveWindow.ScrollColumn = 18
    ActiveWindow.ScrollColumn = 19
    ActiveWindow.ScrollColumn = 20
    ActiveWindow.ScrollColumn = 21
    Range("AJ2").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = ""
    Range("AJ8").Select
    ActiveCell.FormulaR1C1 = ""
    Range("AJ20").Select
    ActiveSheet.Range("$A$1:$AI$120334").AutoFilter Field:=35, Criteria1:="DIR3"
    ActiveWindow.ScrollColumn = 19
    ActiveWindow.ScrollColumn = 18
    ActiveWindow.ScrollColumn = 15
    ActiveWindow.ScrollColumn = 12
    ActiveWindow.ScrollColumn = 9
    ActiveWindow.ScrollColumn = 3
    ActiveWindow.ScrollColumn = 1
    Range("A1:B1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Paste
    Sheets("Feuil2").Select
    Range("K743").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "1"
End Sub

03/09/2019, 13h11
Invité

Citation:

Envoyé par Yams75

Bonjour,

Vous devriez regarder l'utilisation des filtres avancés notamment celle avec export sur une autre feuille. Lien vers le tuto de Philippe TULLIEZ : advancedfilter

Une fois le filtre mis au point, vous pourrez utiliser VBA pour modifier vos critères. Vous serez étonné de la vitesse.
03/09/2019, 14h04
Yams75

Merci de votre aide.

J'ai utilisé le filtre avancé et cela fonctionne. Mais je ne vois pas comment l'utiliser avec une macro.

Tout d'abord, car à chaque fois que j'exporte un critère, je dois exporter la base de données vers une autre feuille donc la plage de critères ne sera pas sur la même feuille et ensuite parce que dans la macro, les critères ne sont pas affichés dur (ex: Dpt1) mais avec l'emplacement de cellule (A1: B2)

Cordialement,
03/09/2019, 14h15
Invité

Citation:

Envoyé par Yams75

Regardez le fonctionnement du fichier joint : Cellule A2 Feuil2. Regardez les modules présents.
04/09/2019, 10h24
Yams75

Mais si ensuite, je souhaite exporter automatiquement chaque lignes avec le même critère dans une nouvelle feuille, je ne vois pas comment le faire de manière automatique.

Merci d'avance.
04/09/2019, 10h30
Invité

Citation:

Envoyé par Yams75

Je ne connais pas votre base de données, mais si vous avez lu le fonctionnement du filtre avancé, il vous faut combiner tous vos paramètres pour n'avoir qu'une seule extraction.

Citation:

Envoyé par Yams75

Mais si ensuite, je souhaite exporter automatiquement chaque lignes avec le même critère dans une nouvelle feuille, je ne vois pas comment le faire de manière automatique.

Merci d'avance.

Bonjour,
Il faut faire une boucle sur chacune des valeurs différentes de ton critère, créer un feuille et faire un filtre avancé pour chacune d'entre elle.

Un exemple a adapter à tes données:

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
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
 
Sub OngletsNom()
'cette macro sépare les données ,de la feuille dont le nom est dans la variable data, en une feuille par valeur différentes
'cette macro n'a pas besoin que les données soient triées car elle utilise les filtres avancés.
 
Application.ScreenUpdating = False
Dim FEUILLE_DEST As Worksheet
Dim var As Object
Dim Plage As Range
Dim Cell As Range
Dim i As Long
Data = "RSS_data"
 
' création de l'objet SortedList
Set var = CreateObject("System.Collections.SortedList")
 
 
With ThisWorkbook.Worksheets(Data).Cells(1, 1)
    Set Plage = .CurrentRegion  ' plage des données (avec les titres)
    For Each Cell In .CurrentRegion.Columns(1).Cells   ' boucle pour créer la liste sans doublon
        If Not var.containskey(Cell.Value) And Cell.Row > 1 Then
            var.Add Cell.Value, Cell.Text
        End If
    Next Cell
End With
 
 
For i = 0 To var.Count - 1
 
    ' ici on gère le fait que la feuille existe ou non
    On Error Resume Next
        Set FEUILLE_DEST = ThisWorkbook.Worksheets(Plage.Cells(1, 1) & "_" & var.getbyindex(i))
    On Error GoTo 0
 
    ' si la feuille n'existe pas : on la crée et la renomme avec le nom de la var
    If FEUILLE_DEST Is Nothing Then
        Set FEUILLE_DEST = ThisWorkbook.Worksheets.Add
        FEUILLE_DEST.Name = Plage.Cells(1, 1) & "_" & var.getbyindex(i)
        FEUILLE_DEST.Move After:=Sheets(ActiveWorkbook.Sheets.Count)
 
    ' si la feuille existe : on efface tout
    Else
        FEUILLE_DEST.Cells.Clear
    End If
 
    ' utilisation du filtre avancé
    With FEUILLE_DEST
        .Cells(1, 1) = Plage.Cells(1, 1) ' nom du critère (l'entête de la colonne 1)
        .Cells(2, 1) = var.getbyindex(i)            ' valeur du critère : nom de la var (qui est le nom de la feuille)
        Plage.AdvancedFilter xlFilterCopy, .Cells(1, 1).CurrentRegion, .Cells(4, 1), False  ' application du filtre avancé
        .Cells(1, 1).Resize(3, 1).EntireRow.Delete ' nettoyage de la zone des critères (= suppression des lignes 1 à 3)
    End With
 
    Set FEUILLE_DEST = Nothing
Next i
 
'suppression des sheets "bilan..." si aucune valeur
Application.DisplayAlerts = False
For Each sh In ThisWorkbook.Sheets
    If sh.Name Like Plage.Cells(1, 1) & "*" Then
        b = False
        For j = 0 To var.Count - 1
        Debug.Print Plage.Cells(1, 1)
        Debug.Print var.getbyindex(j)
        If sh.Name = Plage.Cells(1, 1) & "_" & var.getbyindex(j) Then b = True
        Next j
        If b = False Then sh.Delete
    End If
Next sh
Application.DisplayAlerts = True
'auto ajustement de la taille des colonnes pour plus de lisibilité
For Each sh In ThisWorkbook.Sheets
    sh.Cells.EntireColumn.AutoFit
Next sh
 
Application.ScreenUpdating = True
End Sub