macro pour créer plusieurs fichiers

sniper2002 · 10 Décembre 2010

Bonjour

je suis dans une impasse et j'ai besoin d'aide sur une solution qui me rendra la vie plus simple, mon besoin est le suivant :
j'ai une matrice de données "feuil1", composée de 5 colonnes : "Structure; DIS; Ville; Champ3; Champ4", je souhaite avoir une macro qui permet de repartir les données par ville (colonne C) dans des fichiers distincts l'exemple ci joint contient 27 villes dans la colonne C, donc 27 fichiers à générer, chaque fichier doit être nommer avec le nom de la ville.

l’emplacement pour l'enregistrement des fichiers sera par défaut : C:\test.

restant à votre dispo pour plus d'explication

merci pour vos réponses

Softmama · 10 Décembre 2010

Re : macro pour créer plusieurs fichiers

Bonjour sniper2002,

Vois si ce code fait ce que tu souhaites :

Code:

Sub hum()
Dim Chemin As String, c As Range, d As Range
Application.ScreenUpdating = False
Chemin = [COLOR="red"]"C:\Test"[/COLOR] [COLOR="seagreen"]' A Adapter[/COLOR]
If Len(Dir(Chemin, vbDirectory)) = 0 Then MkDir Chemin
Set c = Range("C2")
Do While c <> "" [COLOR="seagreen"]'Boucle sur chaque ligne[/COLOR]
    If Len(Dir(Chemin & "\" & c & ".xls")) = 0 Then
        Application.Workbooks.Add [COLOR="seagreen"]'Création du fichier s'il n'existe pas[/COLOR]
        ActiveWorkbook.SaveAs Chemin & "\" & c & ".xls"
        Workbooks([COLOR="red"]"Test3.xls"[/COLOR]).Sheets([COLOR="red"]"Feuil1"[/COLOR]).Rows("1:1").Copy Destination:=ActiveWorkbook.Sheets(1).Rows("1:1")
        ActiveWorkbook.Sheets(1).Columns("C:C").Delete
    Else
        Application.Workbooks.Open Chemin & "\" & c & ".xls" [COLOR="seagreen"]'Ou ouverture s'il existe[/COLOR]
    End If
    Set d = ActiveWorkbook.Sheets(1).Range("A65536").End(xlUp).Offset(1, 0)
    [COLOR="seagreen"]'Copie des données utiles[/COLOR]
    d = c(1, -1)
    d(1, 2) = c(1, 0)
    d(1, 3) = c(1, 2)
    d(1, 4) = c(1, 3)
    ActiveWorkbook.Close True [COLOR="seagreen"]'Fermeture du fichier avec sauvegarde[/COLOR]
    Set c = c(2, 1)
Loop
Application.ScreenUpdating = True
End Sub

cf. Fichier joint

sniper2002 · 10 Décembre 2010

Re : macro pour créer plusieurs fichiers

merci pour ce code, lorsque je l'ai appliqué sur le fichier test cela marche rapidement (un nombre limité de ligne), mais sur un fichier de 30K lignes, cela prends un temps fouuu donc, lorsque je compare , je trouve la méthode manuelle est plus rapide para rapport à cette solution.
d’après ce que j'ai compris ta logique est la suivante : pour chaque ligne je viens vérifier si le fichier existe ou pas, si le fichier existe : j'ouvre le fichier et j’intègre la donnée et je ferme fichier si le fichier n'est pas crée, je génère un fichier avec le nom de la ville et j’intègre la donnée.

donc pour chaque ligne il doit ouvrir et fermer un fichier ! cela peut être intéressant si j'ai un grand nombre de ville, mais dans le cas ou j'ai un nombre très réduit pour un nombre important de lignes, cela devient très long

Est ce qu'il y a moyen d'avoir une solution (code) avec le déroulement suivant :
- un compteur pour dénombrer le nombre de ville (n)
- génération des fichiers (n fichier)
- une sélection des données par ville
- intégration des données dans le bon fichier
- enregistrement et fermeture du fichier.

je suis pas expert dans ce domaine, je pense que cela peut m'aider à économiser du temps

j'ai la logique mais j'ai pas la technique c'est mon défaut 🙂

encore une fois merci pour votre aide.

MJ13 · 10 Décembre 2010

Re : macro pour créer plusieurs fichiers

Bonjour Sniper, Softmama

mais sur un fichier de 30K lignes, cela prends un temps fouuu donc, lorsque je compare , je trouve la méthode manuelle est plus rapide para rapport à cette solution.

"un temps fouuu": c'est à dire combien d'heures?

Softmama · 10 Décembre 2010

Re : macro pour créer plusieurs fichiers

Bonjour MJ13, Re sniper,

Je prends en compte ta remarque... Penses-tu qu'il serait faisable de procéder ainsi :
1- Sauvegarder le fichier Test3.xls
2- Trier le fichier sur la colonne des Villes
3- Traiter les données par paquets regroupés puisqu'elles sont désormais triées (Sur 30k villes, gain de temps d'au moins 99% garanti)
4- Fermer tous les fichiers générés en les sauvegardant
5- Fermer le fichier Test3.xls sans le sauvegarder pour retrouver le bon ordre des données.

Si la réponse est OUI, alors, je te ferai ça dans la soirée,pque là, je dois me sauver.
Let me know.

Guest · 10 Décembre 2010

Re : macro pour créer plusieurs fichiers

Bonjour,

A partir du fichier exemple.

La logique:
Créer une liste de villes unique

Code:

[COLOR=blue]Function[/COLOR] GetListeVilles() [COLOR=blue]As[/COLOR] [COLOR=blue]Variant[/COLOR]
    [COLOR=blue]On[/COLOR] [COLOR=blue]Error[/COLOR] [COLOR=blue]GoTo[/COLOR] FinListeVilles
    [COLOR=blue]With[/COLOR] Feuil1
        .Range([I]"C2:C"[/I] & .Cells(.Rows.Count, 1).[COLOR=blue]End[/COLOR](xlUp).Row).AdvancedFilter xlFilterCopy, , Feuil3.Range([I]"A1"[/I]), [COLOR=blue]True[/COLOR]
    [COLOR=blue]End[/COLOR] [COLOR=blue]With[/COLOR]
    [COLOR=blue]With[/COLOR] Feuil3
        GetListeVilles = Application.Transpose(.Range([I]"A1:A"[/I] & .Cells(.Rows.Count, 1).[COLOR=blue]End[/COLOR](xlUp).Row).Value)
    [COLOR=blue]End[/COLOR] [COLOR=blue]With[/COLOR]
FinListeVilles:
    [COLOR=blue]If[/COLOR] Err.Number > 0 [COLOR=blue]Then[/COLOR] MsgBox Err.Number & vbCrLf & Err.Description, vbExclamation, [I]"GetListeVilles"[/I]
[COLOR=blue]End[/COLOR] [COLOR=blue]Function[/COLOR]

Ensuite parcourir cette liste
Pour chaque ville en extraire les informations sur une feuille du classeur.
Copier cette feuille en creant un nouveau classeur.
Enregistrer le nouveau classeur (ne pas oublier d'adapter le chemin)
Fermer le nouveau classeur

Code:

[COLOR=blue]Sub[/COLOR] CreationFichiersVilles()
    [COLOR=blue]Dim[/COLOR] Villes [COLOR=blue]As[/COLOR] [COLOR=blue]Variant[/COLOR]
    [COLOR=blue]Dim[/COLOR] i [COLOR=blue]As[/COLOR] [COLOR=blue]Long[/COLOR]
    [COLOR=blue]Dim[/COLOR] Modecalcul [COLOR=blue]As[/COLOR] XlCalculation
    Villes = GetListeVilles()
 
    [COLOR=green]'Sortir en cas de non liste de ville[/COLOR]
    [COLOR=blue]If[/COLOR] [COLOR=blue]Not[/COLOR] IsArray(Villes) [COLOR=blue]Then[/COLOR] [COLOR=blue]Exit[/COLOR] [COLOR=blue]Sub[/COLOR]
 
    [COLOR=green]'Pour aller plus vite[/COLOR]
    [COLOR=blue]With[/COLOR] Application
        Modecalcul = .Calculation
        .Calculation = xlCalculationManual
        .EnableEvents = [COLOR=blue]False[/COLOR]
        .ScreenUpdating = [COLOR=blue]False[/COLOR]
    [COLOR=blue]End[/COLOR] [COLOR=blue]With[/COLOR]
 
    [COLOR=blue]On[/COLOR] [COLOR=blue]Error[/COLOR] [COLOR=blue]GoTo[/COLOR] FinCreationFichiers
 
    [COLOR=green]'Parcourir le tableau des villes[/COLOR]
    [COLOR=blue]For[/COLOR] i = 1 To [COLOR=blue]UBound[/COLOR](Villes)
        [COLOR=green]'Travailler sur ce classeur[/COLOR]
        [COLOR=blue]With[/COLOR] ThisWorkbook
            [COLOR=blue]With[/COLOR] Feuil2 [COLOR=green]'Travailler sur la feuille Feuil2 (codename)[/COLOR]
                [COLOR=green]'préparation des critères et de la plage d'extraction des données[/COLOR]
                .Range([I]"A1"[/I]) = [I]"Ville"[/I]
                .Range([I]"A4:D4"[/I]) = Array([I]"Structure"[/I], [I]"DIS"[/I], [I]"Champ 3"[/I], [I]"Champ 4"[/I])
                .Range([I]"A2"[/I]) = Villes(i)
                [COLOR=green]'extraction des données[/COLOR]
                 Feuil1.Range([I]"A1"[/I]).CurrentRegion.AdvancedFilter xlFilterCopy, .Range([I]"A1:A2"[/I]), .Range([I]"A4:D4"[/I]), [COLOR=blue]False[/COLOR]
                .Copy [COLOR=green]'Copie le résultat en créant un nouveau classeur ouvert[/COLOR]
            [COLOR=blue]End[/COLOR] [COLOR=blue]With[/COLOR]
        [COLOR=blue]End[/COLOR] [COLOR=blue]With[/COLOR]
 
        [COLOR=green]'Application.DisplayAlerts = [COLOR=blue]True[/COLOR][/COLOR]
        [COLOR=blue]With[/COLOR] ActiveWorkbook [COLOR=green]'travailler sur le nouveau classeur[/COLOR]
            [COLOR=green]'Supprimer les 3 premières lignes[/COLOR]
            .Sheets(1).Range([I]"1:3"[/I]).Delete xlShiftUp
            [COLOR=green]'Sauvegarde du classeur[/COLOR]
            .SaveAs [I]"C:\Test\"[/I] & Villes(i) & [I]".xls"[/I]
            [COLOR=green]'Fermeture[/COLOR]
            .[COLOR=blue]Close[/COLOR]
        [COLOR=blue]End[/COLOR] [COLOR=blue]With[/COLOR]
        [COLOR=green]'Application.DisplayAlerts = [COLOR=blue]False[/COLOR][/COLOR]
 
    [COLOR=green]'Prochaine ville[/COLOR]
    [COLOR=blue]Next[/COLOR] i
FinCreationFichiers:
[COLOR=green]'Remise en état de l'objet application[/COLOR]
    [COLOR=blue]With[/COLOR] Application
        .Calculation = Modecalcul
        .EnableEvents = [COLOR=blue]False[/COLOR]
        .ScreenUpdating = [COLOR=blue]False[/COLOR]
    [COLOR=blue]End[/COLOR] [COLOR=blue]With[/COLOR]
    [COLOR=blue]If[/COLOR] Err <> 0 [COLOR=blue]Then[/COLOR] MsgBox Err.Number & vbCrLf & Err.Description, [I]"CreationFichiersVilles"[/I]
[COLOR=blue]End[/COLOR] [COLOR=blue]Sub[/COLOR]

A+

Staple1600 · 10 Décembre 2010

Bonsoir à tous

Pour Hasco
Oh que ton code est beau, Monsieur Hasco
Quand on le lit c'est un cadeau
On voit que dans VBA tes mots
Choisir les bons, tu sais, Oh Hasco
Que j'aime en buvant mon gaspacho
lire le beau code d'Hasco

Guest · 11 Décembre 2010

Re : macro pour créer plusieurs fichiers

bonjour,

Eh ben JM t'as le gaspach inspiré😱 Merci pour ces compliments. encore faut-il que tout ceci fonctionne.

A++ l'ami

MJ13 · 11 Décembre 2010

Re : macro pour créer plusieurs fichiers

Bonjour à tous

Ges et Softmama: j'ai pas eu le temps de tester vos solutions 😱.

JM: Tu es le nouveau poète d'XLD 🙂.

Voici une version qui grâce aux filtres élaborés, permettent une souplesse de travail.

J'ai mis un stop dans le code (faire F8 pour aller en mode pas à pas et Shift+F8 pour continuer).

Sinon, j'ai extrait les villes sans doublons avec Données Avancées.

macro pour créer plusieurs fichiers

sniper2002

XLDnaute Occasionnel

Pièces jointes

Softmama

XLDnaute Accro

Pièces jointes

sniper2002

XLDnaute Occasionnel

MJ13

XLDnaute Barbatruc

Softmama

XLDnaute Accro

Guest

Guest

Staple1600

XLDnaute Barbatruc

Guest

Guest

MJ13

XLDnaute Barbatruc

Pièces jointes

Discussions similaires

macro pour créer plusieurs fichiers

sniper2002

XLDnaute Occasionnel

Pièces jointes

Softmama

XLDnaute Accro

Pièces jointes

sniper2002

XLDnaute Occasionnel

MJ13

XLDnaute Barbatruc

Softmama

XLDnaute Accro

Guest

Guest

Staple1600

XLDnaute Barbatruc

Guest

Guest

MJ13

XLDnaute Barbatruc

Pièces jointes

Discussions similaires

Privacy & Transparency

Privacy & Transparency