Description d'un script d'éclatement d'un fichier Excel
Bonjour à tous,
J'ai un petit bout de code que je souhaiterai bien comprendre pour mieux l'adapter. A titre indicatif, ce script permet d'éclater un fichier XLSX en autant de fichier XLSX qu'il y a d'élément distinct dans la colonne A.
Le voici :
Sub CreationFichiers()
Dim Mondico As Object
Dim DicoKey
Dim J As Long, NbLg As Long
Dim Chemin As String
Application.ScreenUpdating = False
Chemin = ThisWorkbook.Path & Application.PathSeparator
NbLg = Range("A" & Rows.Count).End(xlUp).Row
Set Mondico = CreateObject("Scripting.dictionary")
For J = 4 To NbLg
Mondico(Range("A" & J).Value) = ""
Next J
With Sheets("Feuil2")
.Cells.Clear
Range("A1:F2").Copy .Range("A1")
Range("B" & NbLg + 5) = Range("A3")
For Each DicoKey In Mondico.keys
Range("B" & NbLg + 6) = DicoKey
Range("A3:F" & NbLg).AdvancedFilter Action:=xlFilterCopy, _
criteriarange:=Range("B" & NbLg + 5).Resize(2, 1), _
copytorange:=.Range("A3:F3")
.Copy
With ActiveWorkbook
.Sheets(1).Name = DicoKey
Application.DisplayAlerts = False
.SaveAs Chemin & "Fichier " & DicoKey
Application.DisplayAlerts = False
.Close
End With
Next DicoKey
.Cells.Clear
End With
Range("B" & NbLg + 5).Resize(2, 1).ClearContents
MsgBox "Création des fichiers terminée"
End Sub
Est-ce que quelqu'un pourrait me le commenter de façon détaillée ?
Pour info, j'ai joint un extrait du fichier qui contient la macro.
En cible, je souhaiterai que ce script insère dans un modèle (à un emplacement bien précis) le contenu de la colonne C pour chaque élément de la colonne A et fasse une sauvegarde du modèle avec dans le nom du fichier la valeur de la colonne A. Ainsi, avec l'exemple, cela ferait 2 fichiers un pour "xxxxxxx" et un second pour "yyyyyy".
Merci beaucoup pour votre aide.
Frédérick.
Bonsoir,
un peu d'aide...
Mais la partie la plus intéressante et bien je n'ai rien à dire
Sub CreationFichiers()
' définition des variables
' on crée un objet VBA Dictionnaire
' le dictionnaire permet de gérer les doublons car dans un dico pas de doublons
Dim Mondico As Object
' on définie
Dim DicoKey
' on définie deux variable de type Long afin de gérer des valeur au delà de 32000 et des poussières car Long vaut 2 147 483 647 ou -2 147 483 647
Dim J As Long, NbLg As Long
' on définie une variable "texte"
Dim Chemin As String
' on arrête la mise à jour de l'écran, cela permet au code d'aller plus vite
Application.ScreenUpdating = False
' Chemin est égal "en texte" au chemin informatique d'accés de ce classeur concatené avec le séparateur de chemin "local" en général "\"
Chemin = ThisWorkbook.Path & Application.PathSeparator
' NbLg = nombre de ligne
' ici on cherche à connaitre le N° de ligne Excel de la dernière valeur de la colonne A
' Pour ce faire on part de tout en bas Rows.count, sous Excel 2003 environ 65000 lignes, sous Excel 2007 et + environ 1 000 000 de lignes
' une fois en bas on recherche la fin de colonne "END" donc dernière cellule avec une valeur, en remontant "xlUp"
' le ".Row" permet de retourner le N° de ligne Excel de la cellule trouvée
NbLg = Range("A" & Rows.Count).End(xlUp).Row
' Set permet d'attribuer "une plage"
Set Mondico = CreateObject("Scripting.dictionary")
' début d'une boucle qui par de la ligne 4 d'Excel de la feuille à la ligne NbLg qui correspond à la dernière cellule pleine de la colonne A
For J = 4 To NbLg
' on remplie le dictionnaire
Mondico(Range("A" & J).Value) = ""
Next J
' on simplifie le code avec cette instruction
With Sheets("Feuil2")
' ici le code est "simplifié" car avant le "." il aurait fallut mettre Sheets("Feuil2")
.Cells.Clear
' on copie la plage de cellule A1:F2 de la feuille active sur la feuille 2 à partir de la cellule A1
Range("A1:F2").Copy .Range("A1")
' la valeur de la cellule en colonne B qui se situe 5 lignes en dessous de la ligne de la dernière cellule de la colonne A est égal à
' la valeur de la cellule A3
Range("B" & NbLg + 5) = Range("A3")
' une boucle ??? sur le dictionnaire, c'est là que je pêche un peu....
For Each DicoKey In Mondico.keys
Range("B" & NbLg + 6) = DicoKey
Range("A3:F" & NbLg).AdvancedFilter Action:=xlFilterCopy, _
criteriarange:=Range("B" & NbLg + 5).Resize(2, 1), _
copytorange:=.Range("A3:F3")
.Copy
' avec le classeur en cours
With ActiveWorkbook
' on renome la feuille 1 avecle nom de la variable DicoKey (valeur qui change à chaque tour de la boucle)
.Sheets(1).Name = DicoKey
' on arrête l'affichage des message d'alerte
Application.DisplayAlerts = False
' on fait une sauvegarde du fichier
.SaveAs Chemin & "Fichier " & DicoKey
' on remet l'affichage des alertes
Application.DisplayAlerts = False
' on ferme le classeur actif
.Close
End With ' on ferme le "avec"
Next DicoKey ' on reboucle dans le dico
' on efface toutes les cellules de la Sheets("Feuil2")
.Cells.Clear
End With ' on ferme le "avec" de Sheets("Feuil2")
' on efface les données de la plage de cellules
Range("B" & NbLg + 5).Resize(2, 1).ClearContents
' on affiche un message disant que c'est fini
MsgBox "Création des fichiers terminée"
End Sub@ bientôt
LouReeD
Salut,
Merci beaucoup ! ça m'aide déjà pas mal.
Du coup, si quelqu'un peut me détailler la boucle, je suis preneur.
Merci pour votre aide.
Bonne journée,
Fred.
Bon, après pas mal de recherches et d'essai, je commence à bien comprendre le code. Il reste une difficulté qui sûrement très bête mais je voudrai adapter ce script pour que la boucle alimente un fichier déjà existant dans un emplacement bien précis au lieu de créer un nouveau fichier. L'objectif est que la macro alimente un modèle qui une fois les données copiées soit sauvegardé avec la variable du dico dans le nom de fichier.
Ayé !! J'ai trouvé une solution. Ce n'est surement pas la plus optimisée ou la plus "propre" mais ça fait ce que je demande !
Voici le code (j'ai mis le fichier en PJ) :
' **********************************************************
Option Explicit
Sub CreationFichiers()
Dim Mondico As Object
Dim DicoKey
Dim J As Long, NbLg As Long
Dim Chemin As String
Application.ScreenUpdating = False
' Chemin est égal "en texte" au chemin informatique d'accés de ce classeur concatené avec le séparateur de chemin "local" en général "\"
Chemin = ThisWorkbook.Path & Application.PathSeparator
' NbLg = nombre de ligne
NbLg = Range("L" & Rows.Count).End(xlUp).Row
' Set permet d'attribuer "une plage"
Set Mondico = CreateObject("Scripting.dictionary")
' début d'une boucle qui par de la ligne 7 d'Excel de la feuille à la ligne NbLg qui correspond à la dernière cellule pleine de la colonne J
For J = 7 To NbLg
' on remplie le dictionnaire
Mondico(Range("L" & J).Value) = ""
Next J
' on simplifie le code avec cette instruction
With Sheets("Feuil2")
' ici le code est "simplifié" car avant le "." il aurait fallut mettre Sheets("Feuil2")
.Cells.Clear
' Copie du titre de la colonne qui contient les notes
Range("N6").Copy .Range("N6")
' la valeur de la cellule en colonne M qui se situe 5 lignes en dessous de la ligne de la dernière cellule de la colonne L est égal à
' la valeur de la cellule L6
Range("M" & NbLg + 5) = Range("L6")
For Each DicoKey In Mondico.keys
' la valeur de la cellule en colonne M qui se situe 6 lignes en dessous de la ligne de la dernière cellule de la colonne L est égal à
' la valeur du dico traitée
Range("M" & NbLg + 6) = DicoKey
' Réalisation d'un filtre avancé
Range("L6:N" & NbLg).AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Range("M" & NbLg + 5).Resize(2, 1), _
CopyToRange:=.Range("N6")
' Copie du résultat dans un nouveau fichier avec le nom d'onglet "Feuil2"
.Copy
ActiveWorkbook.Application.DisplayAlerts = False
Sheets("Feuil2").Activate
Range("N7").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Workbooks.Open Filename:= _
"C:\Users\frederick.dupont\Documents\Test_eclatement\Modèle_formulaire_AMF_zz.xlsx"
Range("N7").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("H1") = DicoKey
ActiveWorkbook.SaveAs Chemin & "FORM_AMF_" & DicoKey
ActiveWindow.Close
ActiveWorkbook.Application.DisplayAlerts = False
ActiveWorkbook.Close
Next DicoKey
.Cells.Clear
End With
Range("M" & NbLg + 5).Resize(2, 1).ClearContents
MsgBox "Création des fichiers terminée"
End Sub
' **********************************************************
Si y a une bonne âme experte qui peut jeter un oeil et me dire s'il y a une faille ou un problème que je n'aurai pas vu ...
Merci et @+