Envoyé par
aude_alti
Philippe,
Es-tu ok, pour que je mette sur le forum tout le code que tu m'as donné?
Avec plaisir.
Il n'y a jamais de problème du moment que l'on cite l'auteur ou sa participation active quand c'est le cas.
Par contre, en effet comme tu le soulignes, avec la mise en page, c'est très très trsè long! Et encore, je n'ai testé que sur la création de 20 onglets (et pas sur 600 comme je vais devoir faire).
Avec 600 onglets, je pense que tu peux aller boire un ou deux cafés.
Pour ce problème là, il y aurait une solution mais cela demande une modification du code.
Au lieu de créer une feuille pour chaque groupe et effectuer la mise en page dans la boucle.
Créer un modèle (feuille vierge mais avec la mise en page souhaitée) et faire une copie de cette feuille modèle en la renommant du nom du groupe et ensuite faire l'exportation.
Cette feuille modèle peut-être cachée et crée dynamiquement ou pas.
Bonjour,
J'ai adapté la procédure pour l'utilisation d'une feuille modèle.
Je crois que l'essayer c'est l'adopter 
(au niveau vitesse il n'y a pas photo).
Ci-dessous la nouvelle version du code où j'ai donc ajouté un argument facultatif TemplateSheet qui est de type Objet WorkSheet
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
| Sub ExportRange(SourceData As Range, areaCriteria As Range, TargetSheetName As String, Optional ClearSheet As Boolean = True, Optional TemplateSheet As Worksheet)
' Fonction qui exporte les données filtrées vers une nouvelle feuille
' Basé sur méthode AdvancedFilter
' Contraintes :
' L'exportation est faite sur le même classeur que SourceData
' La liste exportée est fait sur la première ligne
' Author : Philippe Tulliez http://philippe.tulliez.be
' Date : 2013/03/27 (2013/03/22 v 1.0)
' Version : 3.1
' Upgrade
' 13/03/26 - 2.1 - Ajouté collage largeur de colonne
' 13/03/27 - 2.2 - Correction d'un bug shtTarget.Cells.PasteSpecial au lieu de rngStart
' Rename rngStart -> rngTarget
' 2.3 - Ajouté ctrl du nombre de colonne et sortie de procédure
' 3.1 - Ajouté argument Template
' Arguments
' SourceData - (Range) Plage des données à exporter
' areaCriteria - (Range) 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
' [TemplateSheet] - (obj WorkSheet) Feuille modèle
Const ver As String = "V 3.0"
Const ErrTitle As String = "Procédure - ExportRange " & ver
Dim ErrMsg As String: ErrMsg = "*** Sortie de procédure ***" & vbCrLf & vbCrLf
Dim shtTarget As Worksheet, rngTarget As Range ' rngStar=Cellule où écrire dans la feuille cible
Dim wkb As Workbook: Set wkb = SourceData.Worksheet.Parent
Dim nbRow As Long
' Création de la feuille
Select Case TemplateSheet Is Nothing
Case True ' Création feuille
wkb.Sheets.Add Before:=Sheets(1)
Case False
TemplateSheet.Copy Before:=Sheets(1)
Debug.Print "Copie modèle " & TemplateSheet.Name
End Select
On Error Resume Next
wkb.Sheets(1).Name = TargetSheetName
'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 shtTarget = wkb.Sheets(TargetSheetName): Set rngTarget = shtTarget.Range("A1")
With rngTarget
If ClearSheet Then
.Worksheet.Cells.Clear
Else
nbRow = .CurrentRegion.Rows.Count: nbRow = nbRow + Abs((nbRow > 1))
If nbRow > 1 And rngTarget.CurrentRegion.Columns.Count <> SourceData.Columns.Count Then
ErrMsg = ErrMsg & "Feuille [" & shtTarget.Name & "] nombre de colonnes différent de la source"
MsgBox ErrMsg, vbOKOnly, ErrTitle
Set shtTarget = Nothing: Set rngTarget = Nothing: Set wkb = Nothing
Exit Sub
End If
ClearSheet = nbRow = 1
Set rngTarget = .Worksheet.Range("A" & nbRow) ' Correction 27/3/13 - ajouté parent
End If
End With
' Exportation
With SourceData: .AdvancedFilter xlFilterCopy, areaCriteria, rngTarget: End With
If Not ClearSheet Then rngTarget.EntireRow.Delete: ' Supprime le titre si upgrade
' Collage des largeurs des colonnes
SourceData.Cells.Copy: shtTarget.Cells.PasteSpecial Paste:=xlPasteColumnWidths ' (27/3/13)
Set shtTarget = Nothing: Set rngTarget = Nothing: Set wkb = Nothing
End Sub |
J'avais aussi ajouté cet après-midi un test de nombre de colonnes ce qui est plus prudent si on ajoute des informations avec des colonnes qui auraient été ajoutées ou supprimées.
Il manque le test de concordance des étiquettes de colonnes (même nombre mais pas même libellé)
Pour appeler la procédure s'il y a une feuille modèle.
ExportRange rngData, rngCriteria, rngList.Offset(r), ClearSheet:=False, TemplateSheet:=shtTemplate
ou, s'il y a lieu de recommencer à zéro avec les listes.
ExportRange rngData, rngCriteria, rngList.Offset(r), TemplateSheet:=shtTemplate
Il faut bien entendu créer l'objet modèle (la feuille se nomme Template et a été crée manuellement et n'a que l'en-tête et pied de page.
En rouge les lignes à ajouter dans la procédure ExportDataByAdvancedFilter
1
2
3
4
5
6
7
8
9
10
11
| Sub ExportDataByAdvancedFilter()
' Procédure de création de feuilles
' avec exportation de données filtrées
'
' Déclaration + Initialisation des variables
Const ParamName = "_ParamWrk"
Const TemplateName = "Template" ' Nom de la feuille modèle
Dim rngList As Range, rngData As Range, rngCriteria As Range, r As Long
Dim shtParam As Worksheet, shtTemplate As Worksheet
Dim wkb As Workbook: Set wkb = ThisWorkbook
Set shtTemplate = wkb.Worksheets(TemplateName) ' Feuille modèle |
Le classeur démo sur demande
Répondre avec citation
).
Partager