Code :
- Sub Rectangleàcoinsarrondis1_Cliquer()
- ' Déclaration + Initialisation des variables
- Dim rngList As Range, rngData As Range, rngCriteria As Range, r As Long
- Set rngData = shtData.Range("H1" ).CurrentRegion
- With shtParam
- Set rngList = .Range("C1" ): Set rngCriteria = .Range("F1:F2" )
- End With
- ' 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
- End With
- ' Etape 2 - Boucle sur la liste avec placement du critère
- ' Création nouvelle feuille
- ' Exportation vers nouvelle feuille
- ' Déplacement de cette nouvelle feuille vers un nouveau classeur
- For r = 1 To rngList.CurrentRegion.Rows.Count - 1
- rngCriteria.Cells(2, 1) = rngList.Offset(r) ' Insère le critère
- ' 2.1 - Création d'une feuille
- Sheets.Add before:=Sheets(1): Sheets(1).Name = rngList.Offset(r)
- ' 2.2 - Exportation vers nlle feuille suivant critère
- With rngData
- .AdvancedFilter xlFilterCopy, rngCriteria, Sheets(1).Range("A1" )
- End With
- ' 2.3 - Déplacement de la feuille cers un nouveau classeur
- Sheets(1).Move
- '
- ' Ici code pour sauver classeur, Envoyer par email etc...
- '
- Next
- End Sub
|