Macro VBA : création d'autant de fichiers qu'il y a des code

Le 14/04/2015 à 14:13

Bonjour,

J’ai réalisé une macro mais je ne parviens pas obtenir ce que je veux. Je ne suis pas loin mais il me manque l’essentiel.

Je vous explique : j’ai deux onglets dans lesquels, en colonne A, j’ai un code. La macro créée autant de fichiers qu’il y a de codes.

Mon problème est que les fichiers créés se font sur la base du premier onglet d’abord puis sur la base du deuxième onglet ensuite.

Exemple : il va dans la feuille 1 et prend tous les codes 1138 et fait un fichier, puis prends les codes 1140 et fait de même. Quand il aura fini il fera d’autres fichiers séparés avec le code en colonne A de la feuille 2.

Or je voudrais qu’il créer un fichier avec une feuille 1 (qui reprend le code 1138 par exemple)et une feuille 2 qui reprend le code 1138. Bref qu'il créer les deux onglets dans le même fichier. Puis enregistre quand les 2 feuilles sont créées.

Le code est dans le module « SpliterAgence » du fichier joint. Pouvez vous m’aider ?

569split-fichier.xlsm (39.50 Ko)
Le 14/04/2015 à 21:05

bonjour

comment dire ton code ma provoqué un mal de tête....

voici une proposition qui fait a priori ta demande enregistrer le même numéro de code sur les deux onglets dans un seul fichier....

je te laisse refaire la mise en forme car je ne sais pas si tu fait la mise en forme sur l'onglet 1 ou 2, .....

les fichiers générés sont je pense au bon formalisme de nom et sont enregistrés dans le dossier ou se trouve le fichier contenant la macro...

a+

fred

Petit clin d’œil a CousinHub 

Sub creation_fichiers()
Dim i As Integer
Application.ScreenUpdating = False
Set Plg = Feuil1.Range("A1:C" & Feuil1.Cells(Rows.Count, 1).End(xlUp).Row)
Feuil1.[H1] = Feuil2.[A1]

For i = 2 To Feuil2.[A65536].End(xlUp).Row
Workbooks.Add
Feuil1.[H2] = Feuil2.Range("A" & i)
Plg.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Feuil1.Range("H1:H2"), CopyToRange:=ActiveWorkbook.Sheets(1).Range("A1:C1")
Feuil2.Range("A" & i & ":C" & i).Copy ActiveWorkbook.Sheets(2).[A1]
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\Agence " & Feuil2.Range("A" & i) & ".xls", FileFormat:=xlExcel8
ActiveWorkbook.Close False
Next i
Feuil1.[H1:H2].ClearContents
End Sub
339split-fichier.xlsm (44.48 Ko)
Le 14/04/2015 à 23:47

Bonsoir le fil, bonsoir le forum,

J'ai bien évidemment préféré la solution de Fred mais comme j'ai bossé dessus je me permets d'envoyer cette autre proposition :

Sub Macro1()
Dim CO As Workbook 'déclare la variable CO (Classeur Original)
Dim OO1 As Worksheet 'déclare la variable OO1 (Onglet Original 1)
Dim OO2 As Worksheet 'déclare la variable OO2 (Onglet Original 2)
Dim D As Object 'déclare la variable D (Dictionnaire)
Dim O As Worksheet 'déclare la variable O (Onglets)
Dim TC As Variant 'déclare la variable TC (Tableau de Cellules)
Dim I As Long 'déclare la variable I (Incrément de lignes)
Dim TMP As Variant 'déclare la variable TMP (tableau TeMPoraire)
Dim CC As Workbook 'déclare la variable CC (Classeur Copie)
Dim OC1 As Worksheet 'déclare la variable OC1 (Onglet Copie 1)
Dim OC2 As Worksheet 'déclare la variable OC2 (Onglet Copie 2)
Dim PL As Range 'déclare la variable PL (PLage)
Dim PLV As Range 'déclare la variable PLV (PLage Visible)

Set CO = ThisWorkbook 'définit le classeur original CO
ChDir (CO.Path) 'définit le dossier courant (dossier de CO)
Set OO1 = CO.Sheets(1) 'définit l'onglet OO1
Set OO2 = CO.Sheets(2) 'définit l'onglet OO2
Set D = CreateObject("Scripting.Dictionary") 'définit le dictionnaire D
For Each O In CO.Sheets 'boucle 1 : sur tous les onglets O du classeur CO
    TC = O.Range("A1").CurrentRegion 'définit le tableau de cellule TC
    For I = 2 To UBound(TC, 1) 'boucle 2 : sur toutes les lignes I du tableau de cellules TC (en partant de la seconde)
        D(TC(I, 1)) = "" 'alimente le dictionnaire D avec la valeur ligne I colonne 1 (=A) de TC
    Next I 'prochaine ligne de la boucle 2
Next O 'prochain onglet de la bouce 1
TMP = D.keys 'récupère dans le tableau temporaire TMP la liste des éléments du dictionnaire D sans doublon
Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
For I = 0 To UBound(TMP, 1) 'boucle sur tous les élément du tableau temporaire TMP
    Workbooks.Add 'ajoute une nouveau classeur
    Set CC = ActiveWorkbook 'définit le classeur CC
    Set OC1 = CC.Sheets(1) 'définit l'ongle OC1
    Set OC2 = CC.Sheets(2) 'définit l'ongle OC2
    Set PL = OO1.Range("A1").CurrentRegion 'définit la plage PL
    OO1.Range("A1").AutoFilter Field:=1, Criteria1:=TMP(I) 'filtre la colonne 1 de l'onglet OO1 avec TMP(I) comme critère
    Set PLV = PL.SpecialCells(xlCellTypeVisible) 'définit la plage PLV (lignes visibles de la plage PL après le filtre)
    PLV.Copy OC1.Range("A1") 'copie la plage PLV dans la cellue A1 de l'onglet OC1
    Set PL = OO2.Range("A1").CurrentRegion 'redéfinit la plage PL
    OO2.Range("A1").AutoFilter Field:=1, Criteria1:=TMP(I) 'filtre la colonne 1 de l'onglet OO2 avec TMP(I) comme critère
    Set PLV = PL.SpecialCells(xlCellTypeVisible) 'redéfinit la plage PLV (lignes visibles de la plage PL après le filtre)
    PLV.Copy OC2.Range("A1") 'copie la plage PLV dans la cellue A1 de l'onglet OC2
    CC.SaveAs (TMP(I) & ".xlsx") 'enregistre le classeur CC
    CC.Close SaveChanges:=False 'ferme le classeur CC
Next I 'prochain élément de la boucle
OO1.Range("A1").AutoFilter 'supprime le filtre automatique de l'onglet OO1
OO2.Range("A1").AutoFilter 'supprime le filtre automatique de l'onglet OO2
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
MsgBox "Transfert terminé !" 'message
End Sub
Le 15/04/2015 à 13:40

Merci à vous deux pour votre travail. En effet votre code set bien plus pertinent

Fred2406, en quelques lignes on peut avoir quelquse chose de pas mal. Cependant ton code ne créer pas d'entête en feuille 2 et s'il y a des doublons de codes le traitement de demande d'écraser le précédent fichier créé. J'aurais dû préciser cette éventualité. Je joint de nouveau le fichier avec des doublons en feuille 2 (Module "SpliterParOnglet1")

ThauTheme, le code à l'air de fonctionner, il prend en compte les éventuels doublons en feuille 2

Reste maitenant à étudier votre code. Merci encore

137split-fichier-1.xlsm (52.41 Ko)
Le 15/04/2015 à 17:15

Bonjour

ci joint la version 2 qui s'occupe des doublons de la feuille 2 et qui écrase les fichiers si on relance la macro

j'ai mis en plus un ajustement auto des colonnes sur les deux feuilles des nouveaux fichiers ainsi que le quadrillage des cellules occupées

a+

fred

486split-fichierv2.xlsm (51.08 Ko)
Le 15/04/2015 à 19:25

Merci Fred,

ça fonctionne bien

A+

Rechercher des sujets similaires à "macro vba creation autant fichiers code"