Création d'un fichier Excel à chaque rupture d'un fichier Excel de référence.

Version imprimable

12/05/2010, 14h46
Richard_35

Création d'un fichier Excel à chaque rupture d'un fichier Excel de référence.
Bonjour à tous,

Je fais appel à une bonne âme de développeur afin de créer un programme qui permettrait de créer autant de fichier Excel que de rupture sur un champ donné d'un fichier Excel de référence.

Exemple :
Soit le fichier Excel de référence toto.xls :
Code:

1 2 3 4 5 A B C D E Ligne 1 aaa 000 111 222 333 Ligne 2 aaa 444 555 666 777 Ligne 3 bbb 888 999 101 111 Ligne 4 ccc 121 131 141 151
Création d'un bouton qui génèrerait, dans le même répertoire :
1 fichier Excel nommé aaa.xls composé de :
Code:

1 2 3 A B C D E Ligne 1 aaa 000 111 222 333 Ligne 2 aaa 444 555 666 777
1 fichier Excel nommé bbb.xls composé de :
Code:

1 2 A B C D E Ligne 1 bbb 888 999 101 111
1 fichier Excel nommé ccc.xls composé de :
Code:

1 2 A B C D E Ligne 1 ccc 121 131 141 151
Merci d'avance de votre aide,
Richard.

Salut

Essaye ça

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
Sub Ruptures()
Dim i, J
Dim nom
 
nom = (ThisWorkbook.Name)
i = 1
J = 1
 
While Range("A" & i) <> ""
 
If Range("A" & i) <> Range("A" & i + 1) Then
 
Rows(J & ":" & i).Select
  Selection.Copy
  Workbooks.Add
 
    Rows(1 & ":" & 1).Select
    ActiveSheet.Paste
    ActiveWorkbook.SaveAs Filename:="D:\" + Range("A" & 1)
 
 
   Windows(nom).Activate
    Sheets("Feuil1").Select
J = i + 1
End If
 
i = i + 1
 
Wend
End Sub

17/05/2010, 16h23
Richard_35

Bonjour le_dilem,

Parfait !
C'est, exactement, ce que je souhaitais.

Merci encore,
Richard.

Add-on

Bonjour à tous,

Juste un petit add-on, gentiment développé par le_dilem (merci encore) qui permet de récupérer la ligne d'entête pour tous les fichiers Excel générés à chaque rupture :

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
Sub RupturesAvecEntete()
Dim i, J
Dim nom
Dim ligne1
 
nom = (ThisWorkbook.Name)
i = 2
J = 2
 
ligne1 = Rows(1 & ":" & 1)
 
While Range("A" & i) <> ""
If Range("A" & i) <> Range("A" & i + 1) Then
 
Rows(J & ":" & i).Select
  Selection.Copy
  Workbooks.Add
 
  Rows(1 & ":" & 1) = ligne1
    Rows(2 & ":" & 2).Select
    ActiveSheet.Paste
    ActiveWorkbook.SaveAs Filename:="C:\Tests_divers\" + Range("A" & 2)
 
   Windows(nom).Activate
    Sheets("Feuil1").Select
 
J = i + 1
End If
 
i = i + 1
 
Wend
End Sub

A bientôt,
Richard.

18/06/2025, 17h41
rebalec

Merci pour vos solutions !! Cela fonctionne vraiment tres bien.

Est il maintenant possible de créer n onglets avec le meme script, sur n onglets différents sur le fichier de base ?

Hello,

une adaptation vite fait

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
Sub RupturesAvecEntete()
 
    Dim i, J
    'Dim nom
    Dim ligne1
 
    'nom = (ThisWorkbook.Name)
    i = 2
    J = 2
 
    ligne1 = Rows(1 & ":" & 1)
 
    While Range("A" & i) <> ""
        If Range("A" & i) <> Range("A" & i + 1) Then
 
            Rows(J & ":" & i).Select
            Selection.Copy
            'Workbooks.Add
            Sheets.Add After:=Sheets(Sheets.Count)
            Rows(1 & ":" & 1) = ligne1
            Rows(2 & ":" & 2).Select
            ActiveSheet.Paste
            'ActiveWorkbook.SaveAs Filename:="C:\Tests_divers\" + Range("A" & 2)
 
            'Windows(nom).Activate
            Sheets("Feuil1").Select
 
            J = i + 1
        End If
 
        i = i + 1
 
    Wend
End Sub

NB : ça mériterait une optimisation, là c'est un peu en mode "cochon" :aie:

19/06/2025, 16h35
rebalec

merci beaucoup !!

encore un petit chouilla : lorsque on met en mémoire la ligne 1, on perd son format en la copiant sur la nouvelle feuille. Comment faire pour garder également son format ?
20/06/2025, 10h10
deedolith

Hello,

C'est la méthode PasteSpecial() de l'objet Worksheet ou Range qui s'occupe de cela.
20/06/2025, 10h51
rebalec

merci. comment l'intégrer dans ce script ?
20/06/2025, 11h01
tototiti2008

Bonjour,

pour te répondre on aurait besoin de savoir quelle partie du format ne suit pas
le code de Nain fait un simple copier coller, qui normalement colle tout (les formats aussi)
20/06/2025, 11h33
rebalec

C'est la ligne 1 (en tete ) qui est mise en mémoire.
20/06/2025, 11h42
deedolith

Heu ...
A un moment donné, il faut savoir chercher par soit même, d'autant que l'on dispose maintenant d'outils surpuissant: Les intelligences artificielles.

Avec Copilot par exemple:
Explique moi ce script ?
Quelle instruction permet de coller ?
Quelle instruction utiliser pour coller tout en conservant la mise en forme ?

Même si les réponses des IAs ne sont pas toujours pertinentes, pour des cas simple, tu trouveras ton bonheur.

Hello,

une version faite avec ChatGPT

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
Sub Ruptures_Avec_Entete()
 
    Dim ws As Worksheet, newWs As Worksheet
    Dim i As Long, debut As Long, dernier As Long
 
    Set ws = Sheets("Feuil1")
    dernier = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    debut = 2
 
    For i = 2 To dernier
        If ws.Cells(i, 1).Value <> ws.Cells(i + 1, 1).Value Then
            Set newWs = Sheets.Add(After:=Sheets(Sheets.Count))
            ws.Rows(1).Copy Destination:=newWs.Rows(1)
            ws.Rows(debut & ":" & i).Copy Destination:=newWs.Rows(2)
            debut = i + 1
        End If
    Next i
 
End Sub