macro pour éclater un fichier excel en plusieurs

Version imprimable

23/02/2016, 11h42
oz2007

1 pièce(s) jointe(s)

macro pour éclater un fichier excel en plusieurs

Hello
Pièce jointe 201634
Alors voici mon problème. Je dois créer une macro qui me permet d’éclater les lignes de mon fichiers en pleins de fichiers excel sous le principe suivant (voir PJ) :

- Chaque fichier doit contenir un seul cas de test sans la ligne de titre. Les cas de tests sont les lignes jaunes+ les lignes blanches en dessous (jusqu’à la prochaine ligne jauneàà
- Chaque fichier doit se nommer VDxxx (le xxx étant dans la colonne C de la ligne jaune)

Voilà je ne sais même pas si c’est faisable, je sèche complétement…
Merci infiniment pour votre aide !!
23/02/2016, 13h30
halaster08

Bonjour,

Oui c'est faisable, mais avec une autre condition que le changement de couleurs pour différencier les lignes ce serait plus simple, perso je ne saurais pas traduire en vba "si ligne jaune"
Tu as juste besoin d'une boucle et de 2 compteurs pour le début et la fin de la zone a copier.

L'algo suivant devrait faire ce que tu recherche:

initialisation des compteurs
boucle while sur les lignes
si "ligne jaune"
maj du compteur de fin
copie zone
creation d'un nouveau classeur
lui donner le nom dans ta colonne C
collage
maj du compteur de début
fin si
fin while
23/02/2016, 13h53
oz2007

Hello,

Merci pour ta réponse mais je suis débutante en vba et du coup ta réponse ne me parle pas trop...qu'entends tu par compteur?

Merci d'avance
23/02/2016, 14h05
halaster08

j'entends par compteur une variable de type integer qui te sert donc a stocker un nombre ici c'est pour avoir le numéro de la première et de la dernière ligne de la zone que tu veux copier.

edit:
en gros appelons "d" pour début et "f" pour fin deux variables.
si tu veux les entêtes tu commence a d=1 sinon d=2

tu parcours les lignes (boucle while)

si la ligne est jaune (ex la 10ème) le compteur f =numero de ligne-1 (ex: 9)
tu copie colle les lignes 1 ou 2 à 9
d= numero de ligne (ex 10)
fin si
23/02/2016, 14h29
oz2007

merci pour ton retour. Les "d" et les "f" doivent être intégrées dans la macro ou c'est quelque chose que je dois faire dans mon fichier source?

oui c'est intégré dans la macro

je t'ai retrouvé le code d'une macro où j'ai fait qqch de similaire, je découpe un fichier puis j'envoie par mail, en nettoyant un peu tu devrais y trouver ton bonheur, à l'exeption du "si ligne jaune"

Code:

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
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
Sub decoupage_et_mail()
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With 'pour ne pas avoir de message d'alertes (confirmation a chaque suppression d'onglets / écrasement de fichier existant ...)
' attention pour les phases de test il vaut mieux ne pas le mettre
 
Dim ObjOutlook As New Outlook.Application
Dim oBjMail
Dim Nom_Fichier As String
Dim i As Integer
Dim t As Integer
Dim a As Integer
'declaration des variables
 
Windows("Cotations vérif_Final.xlsm").Activate
Range("A1:K13708").Select
    ActiveWorkbook.Worksheets("Fiche travail").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Fiche travail").Sort.SortFields.Add Key:=Range( _
        "A2:A13708"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Fiche travail").Sort
        .SetRange Range("A1:K13708")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
'Tri du fichier par rapport a la première colonne (ici nom de l'agence)
Chemin = ActiveWorkbook.Path
 
i = 2
t = i
' deux compteur pour le découpage, t pour le début et i pour la fin
a = 0
' compteur pour le nom d'itération (ici on sait qu'on a 162 agences)
 
Do While a < 162
 
t = i 'debut de la zone de découpage
nom = Cells(t, 1) ' on récupère le nom de l'agence
 
Do While Cells(i, 1) = Cells(i + 1, 1) 'tant que l'agence de ne change pas
i = i + 1 'on incrémente le compteur
Loop
 
Workbooks.Add
ActiveWorkbook.SaveAs Filename:=Chemin & "\" & nom & ".xlsx"
'on crée et renomme un fichier excel au nom de l'agence
 
Sheets("Feuil2").Select
    ActiveWindow.SelectedSheets.Delete
    Application.ScreenUpdating = True
Sheets("Feuil3").Select
    ActiveWindow.SelectedSheets.Delete
    Application.ScreenUpdating = True
'on supprime les feuilles inutiles
 
Windows("Cotations vérif_Final.xlsm").Activate
Range(Cells(1, 1), Cells(1, 8)).Select
Selection.Copy
Windows(nom & ".xlsx").Activate
Range("A1").Select
ActiveSheet.Paste
'copie des en-têtes
Windows("Cotations vérif_Final.xlsm").Activate
Range(Cells(t, 1), Cells(i, 8)).Select
Selection.Copy
Windows(nom & ".xlsx").Activate
Range("A2").Select
ActiveSheet.Paste
'copie des donnée entre les lignes t et i
ActiveWorkbook.Save
ActiveWorkbook.Close
 
Windows("Cotations vérif_Final.xlsm").Activate 'envoi du mail
 Set ObjOutlook = New Outlook.Application
    Set oBjMail = ObjOutlook.CreateItem(olMailItem)
    With oBjMail
        .To = Cells(t, 9) ' le destinataire
       .Subject = Cells(t, 10) ' l'objet du mail
       .Body = Cells(t, 11) 'le corps du mail ..son contenu
       .Attachments.Add Chemin & "\" & nom & ".xlsx" '"C:\Data\essai.txt" ' ou Nomfichier
       .Display
  SendKeys "^{ENTER}" 'pour éviter la confirmation par outlook
    End With
 
 
i = i + 1
a = a + 1
Loop
 
Application.ScreenUpdating = True
Application.DisplayAlerts = True
'réactivation des alertes
 
End Sub

Hello,

Je pense être bien partie mais ça bloc au niveau:

Code:

Do While Cells(i, 1) = Cells(i + 1, 1)

'tant que l'agence de ne change pas

Ma macro:

Code:

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
Sub decoupage_et_mail()
With Application
.ScreenUpdating = False
.DisplayAlerts = False
 
 
 
Windows("Compil.xlsm").Activate
Range("A1:K13708").Select
    ActiveWorkbook.Worksheets("JdT").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("JdT").Sort.SortFields.Add Key:=Range( _
        "A2:A13708"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("JdT").Sort
        .SetRange Range("A1:AC13708")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
'Tri du fichier par rapport a la première colonne (ici nom de l'agence)
Chemin = ActiveWorkbook.Path
 
i = 2
t = i
' deux compteur pour le découpage, t pour le début et i pour la fin
a = 0
' compteur pour le nom d'itération (ici on sait qu'on a 162 agences)
 
Do While a < 162
 
t = i 'debut de la zone de découpage
nom = Cells(t, 1) ' on récupère le nom de l'agence
 
Do While Cells(i, 1) = Cells(i + 1, 1) 'tant que l'agence de ne change pas
i = i + 1 'on incrémente le compteur
Loop
 
Workbooks.Add
ActiveWorkbook.SaveAs Filename:=Chemin & "\" & nom & ".xlsx"
'on crée et renomme un fichier excel au nom de l'agence
 
 
Windows("Compil.xlsm").Activate
Range(Cells(t, 29), Cells(i, 29)).Select
Selection.Copy
Windows(nom & ".xlsx").Activate
Range("A2").Select
ActiveSheet.Paste
'copie des donnée entre les lignes t et i
ActiveWorkbook.Save
ActiveWorkbook.Close
 
 
 
 
 
i = i + 1
a = a + 1
Loop
End With
End Sub

23/02/2016, 15h27
halaster08

Déjà pense à mettre a mettre la balise CODE quand tu poste du code sinon c'est illisible.
Ensuite je t'ai dit que ma macro fesait qqch de similaire pas identique, tu ne peux pas juste changer le copier le coller ...
As tu des nom d'agences dans ta première colonne ? je ne crois pas donc

Code:

Do While Cells(i, 1) = Cells(i + 1, 1) 'tant que l'agence de ne change pas

a très peu de chance de marcher ...
23/02/2016, 16h44
oz2007

dsl je débute et avec ta macro j'ai bien mes fichiers qui se créent. En faite la ligne de code dont on a parlé pose problème pour la dernière ligne (j'ai ajouté mes numéro de test en colonne A donc plus de problème). Toi tu connaissait exactement le nombre d'agence mais moi je ne connais pas mon nombre de cas, est ce que le problème peut venir de là?

Petite précision: sur le code "

Code:

Do While Cells(i, 1) = Cells(i + 1, 1)

" pour la dernière ligne du tableau j'ai l'erreur "Erreur d'exécution '6': Dépassement de capacité"
Sinon tout le reste fonctionne --> mes fichiers sont crées avec les bons copier/coller :)

Re petite précision sur la ligne qui bloc. La macro fonctionne bien si j'indique dans "

Code:

Do While a < xx

" le nombre exacte de cas de test que j'ai dans mon fichier. Le problème est que je ne peux pas le connaitre à l'avance.
23/02/2016, 16h57
halaster08

Citation:

Envoyé par oz2007

Petite précision: sur le code "Do While Cells(i, 1) = Cells(i + 1, 1)" pour la dernière ligne du tableau j'ai l'erreur "Erreur d'exécution '6': Dépassement de capacité"
Sinon tout le reste fonctionne --> mes fichiers sont crées avec les bons copier/coller :)

Si tu as moins de 162 fichier a faire c'est normal, après ton dernier fichier toutes les cellules sont vides donc égales donc i s'incrémente jusqu'a l'infini (en théorie, heureusement Excel s'arête avant et t'insulte).

Pour résoudre ce problème tu dois remplacer la condition du premier while, le compteur sur le nombre d'agence étant inutile pour toi.
Tu peux le remplacer par i < nombre de lignes de ton fichier.

edit: j'ai vu que tu avais laissé le tri en début de macro, est-ce vraiment utile?
23/02/2016, 18h28
oz2007

Merci pour ton retour, ça fonctionne bien...pour le tri non et ça me pose problème car il me tri mal mes données mais quand j'enlève le paragraphe sur les tris mes fichiers ne se créent plus...

Excuse moi je t dit n'importe quoi sur le dernier poste...me tri ne change rien j'avais juste un problème dans ma macro :)

Donc en indiquant le nb exacte de ligne ça fonctionne

Code:

Do While i < 25

Est ce qu'il existe une option où tu peux indiquer d'aller jusqu'à la dernière cellule vide?
23/02/2016, 19h02
halaster08

il n'y pas d'option, mais avec le bon code c'est possible, c'est une question récurente cherche sur ce forum ou sur google et tu auras ta réponse
23/02/2016, 20h51
oz2007

Ok je vais regarder cela merci encore pour ton aide, cette macro est très pratique!! Bonne soirée