maryrossignon
XLDnaute Junior
Bonjour le Forum,
A partir d'un classeur, le code ci-dessous me permet d'exporter des sous-totaux dans de nouveaux classeurs par responsable.
Est que quelqu'un pourrait m'aider et me dire comment modifier le code pour qu'il exporte également la mise en page du classeur de départ vers les nouveaux classeurs créés (code créé par BrunoM45) :
PS : Trouvez ci-joint, un échantillon du fichier en version 2003 mais que j'utilise à la base en version 2007.
Cordialement
MaryR
A partir d'un classeur, le code ci-dessous me permet d'exporter des sous-totaux dans de nouveaux classeurs par responsable.
Est que quelqu'un pourrait m'aider et me dire comment modifier le code pour qu'il exporte également la mise en page du classeur de départ vers les nouveaux classeurs créés (code créé par BrunoM45) :
Code:
Sub ExportParResponsable()
Dim DerLig As Long, Lig As Long, LigDeb As Long
Dim NomResp As String, ShtNew As Worksheet
Dim VPath As String
' Effectuer peut-être un TRI ici
'Cells.Sort Key1:=Range("K2"), Order1:=xlAscending, _
Key2:=Range("F2"), Order2:=xlAscending, _
Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
' Créer les sous-totaux
Cells.RemoveSubtotal
Cells.Subtotal GroupBy:=6, Function:=xlSum, TotalList:=Array(8, 9, 10), _
Replace:=True, PageBreaks:=True, SummaryBelowData:=True
' Exporter chaque groupe du même responsable
With ActiveSheet
DerLig = .Range("F" & Rows.Count).End(xlUp).Row - 1
LigDeb = 2: NomResp = ""
' Récupérer le chemin d'accès de ce classeur
VPath = ActiveWorkbook.Path & "\"
' Pour chaque ligne
For Lig = 2 To DerLig
' Mémoriser le nom du responsable
If NomResp = "" Then NomResp = .Range("K" & Lig)
' Si la ligne contient le terme "Total"
If InStr(1, .Range("F" & Lig), "Total") > 0 Then
' Vérifie si la suivante appartient au même RESPONSABLE
If .Range("K" & Lig + 1) <> NomResp Then
' On crée une nouvelle feuille
Sheets.Add After:=Sheets(Sheets.Count)
' On mémorise dans une variable objet
Set ShtNew = ActiveSheet
.Range("A1:N1,A" & LigDeb & ":N" & Lig).Copy Destination:=ShtNew.Range("A1")
ShtNew.Name = NomResp
' On déplace la feuille dans un nouveau classeur
ShtNew.Move
' On sauvegarde ce nouveau classeur
ActiveWorkbook.SaveAs Filename:=VPath & NomResp & "_ECHEANCIER-CLIENTS.xlsx"
ActiveWorkbook.Close
' Mémoriser la nouvelle ligne de départ
LigDeb = Lig + 1: NomResp = ""
' Effacer la variable objet
Set ShtNew = Nothing
End If
End If
Next Lig
End With
' Petit message
MsgBox "Exportation terminée !", vbInformation, "Yeeessss"
End SubPS : Trouvez ci-joint, un échantillon du fichier en version 2003 mais que j'utilise à la base en version 2007.
Cordialement
MaryR
