Discussion :

[oz2007]

Hello
test.xlsx
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 !!

[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

[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

[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

[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?

[halaster08]

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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