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 |
Macro pour filtrer dans une base
Répondre avec citation
Envoyé par Yams75
Partager