Bonjour,
Comme le sujet m'intéresse puisqu'il traite du filtre élaboré, j'ai passé un peu de temps pour adapter le code.
Voici le code qui comprends deux procédures mais j'aurais pu le faire en trois procédures cela aurait été plus propre.
La premier procédure nommée ExportDataByAdvancedFilter est le début du programme qui crée dynamiquement une feuille paramètres et qui la détruit ensuite.
La deuxième procédure ExportRange est la procédure qui exporte les données en utilisant la méthode AdvancedFilter (filtre avancé). Cette procédure crée également les feuilles d'une façon dynamique.
Il y a un argument facultatif nommé ClearSheet qui est à True par défaut.
Cela signifie que si l'on souhaite écraser les anciennes valeurs contenues dans les feuilles en les remplaçant par les nouvelles, la syntaxe est
ExportRange rngData, rngCriteria, rngList.Offset(r)
ou
ExportRange rngData, rngCriteria, rngList.Offset(r), ClearSheet:=True
Si l'on souhaite ajouter les nouvelles lignes aux anciennes présentes, la syntaxe est
ExportRange rngData, rngCriteria, rngList.Offset(r), ClearSheet:=False
C'est ce dernier cas qui pour l'instant est programmé. Voir la partie mis en rouge ligne 27 dans la première procédure
Il y a en début de la première procédure une constante qui est le nom que tu as donné à ta feuille Sheet n°1
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
| Option Explicit
Const shtName = "Sheet n°1"
Sub ExportDataByAdvancedFilter()
' Déclaration + Initialisation des variables
Const ParamName = "_ParamWrk"
Dim rngList As Range, rngData As Range, rngCriteria As Range, r As Long
Dim shtParam As Worksheet
Dim wkb As Workbook: Set wkb = ThisWorkbook
Application.ScreenUpdating = False
CreaSheet: ' Création de la feuille paramètre
On Error Resume Next
Set shtParam = wkb.Worksheets(ParamName)
If Err Then wkb.Worksheets.Add.Name = ParamName: GoTo CreaSheet
On Error GoTo 0
With shtParam
Set rngList = .Range("A1"): Set rngCriteria = .Range("C1:C2")
End With
Set rngData = wkb.Worksheets(shtName).Range("A1").CurrentRegion
' Etape 1 - Création d'une liste unique basée sur la colonne 1
With rngData
.Resize(, 1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=rngList, Unique:=True
With shtParam: .Range("C1") = .Range("A1"): End With
End With
' Etape 2 - Exportation vers nouvelle feuille (Dans la boucle)
For r = 1 To rngList.CurrentRegion.Rows.Count - 1
rngCriteria.Cells(2, 1) = rngList.Offset(r) ' Insère le critère
ExportRange rngData, rngCriteria, rngList.Offset(r), ClearSheet:=False
Next
' Destruction de la feuille paramètres
Application.DisplayAlerts = False
shtParam.Delete: Set shtParam = Nothing
Application.DisplayAlerts = True
'
Set rngList = Nothing: Set rngData = Nothing: Set rngCriteria = Nothing
Application.ScreenUpdating = True
End Sub |
La procédure d'exportation
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
| Sub ExportRange(SourceData As Range, areaCriteria As Range, TargetSheetName As String, Optional ClearSheet As Boolean = True)
' Fonction qui exporte les données filtrées vers une nouvelle feuille
' Contrainte l'exportation est faite sur le même classeur que SourceData
' SourceData - (Range) la plage des données à exporter
' areaCriteria - (Range) la plage des critères
' TargetSheetName - (String) Nom de la feuille où exporter les données filtrées
' [ClearSheet] - Boolean [d:=True] si False ajoute les lignes exportées derrières les autres
Dim rngStart As Range ' Cellule où écrire dans la feuille cible
Dim nbRow As Long
Dim wkb As Workbook: Set wkb = SourceData.Worksheet.Parent
On Error Resume Next
wkb.Sheets.Add before:=Sheets(1): wkb.Sheets(1).Name = TargetSheetName ' Création feuille
Application.DisplayAlerts = False
If Err Then wkb.Sheets(1).Delete ' Delete NewSheet if TargetSheetName Exist
Application.DisplayAlerts = True
On Error GoTo 0
' Exportation vers nlle feuille suivant critère
Set rngStart = wkb.Sheets(TargetSheetName).Range("A1")
With rngStart
If ClearSheet Then
.Worksheet.Cells.Clear
Else
nbRow = .CurrentRegion.Rows.Count: nbRow = nbRow + Abs((nbRow > 1))
ClearSheet = nbRow = 1
Set rngStart = .Range("A" & nbRow)
End If
End With
' Exportation
With SourceData: .AdvancedFilter xlFilterCopy, areaCriteria, rngStart: End With
If Not ClearSheet Then rngStart.EntireRow.Delete
Set rngStart = Nothing: Set wkb = Nothing
End Sub |
Création de plusieurs onglets avec saut de ligne
Répondre avec citation
....
).
Envoyé par aude_alti
mais cela demande un peu de modification.
Partager