Créer un fichier excel par ligne d'un fichier excel source

Version imprimable

Bonjour,
je souhaiterais faire une macro pour créer un fichier excel, par ligne d'un fichier excel source, par exemple :

FichierSOurce:
nom prenom age
ligne 1 : Pierre Dupont 36 etc....
ligne 2: Croc Odile 42 ......

et donc quand je lancerais ma macro , il me créerait 2 fichiers un pour les données de la ligne 1 et l'autre pour celles de la ligne 2.

J'ai essayé cette macro mais il me dit que mes fichiers sont endommagés :
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 Sub creer() Dim cell As Range, FF&, Counter& For Each cell In Range("A1:OJ1", Range("A" & Rows.Count).End(xlUp)) If Len(cell) > 0 Then FF = FreeFile() Open ThisWorkbook.Path & "\" & Range("A" & cell.Row).Value & ".txt" For Output As #FF Print #FF, cell.Text Close #FF Counter = Counter + 1 End If Next cell 'MsgBox Counter & " fichiers créés. ", , "Fin de traitement" End Sub
J'ai regardé plusieurs morceaux de codes mais rien y fait, pouvez vous m'aider svp ?

Merci beaucoup

01/06/2023, 11h03
Franc

Salut, j'ai testé ta macro et chez moi elle fonctionne sans provoquer d'erreur, les fichiers sont bien créés, donc le problème doit être ailleurs que dans la macro.
01/06/2023, 14h50
android59

1 pièce(s) jointe(s)

j'ai restesté la macro et quand je laisse "txt", les fichiers sont vide, mais quand je me .xlsx, j'ai le message d'erreur suivant :
Pièce jointe 639553

Les fichiers excels sont bien créés en fonction du nombre de ligne, mais impossible de les ouvrirs, sauriez vous svp m'indiquer une méthode pour avoir dans chaque fichier excel créé,les données se trouvant dans chaque ligne du fichier source?
merci

J'ai utilisé un code qui a l'air pas mal, il me créé mes fichiers, mais dans chaque fichier, j'ai que l'entete, il doit y avoir quelque chose dans le code à fair emais j'ai du mal à trouver :

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
 
dossier = ThisWorkbook.Path & "\" '<<<adapter emplacement destination
Set dico = CreateObject("Scripting.dictionary")
 
Application.ScreenUpdating = False
With Sheets("Feuil1")
    dl = .Cells(.Rows.Count, 1).End(xlUp).Row
    For i = 2 To dl
        If Not dico.exists(.Cells(i, 1).Value2) Then
            dico(.Cells(i, 1).Value2) = ""
            chemin = dossier & .Cells(i, 1).Value2  '<<<chemin (ADAPTER NOM FICHIER) "UR " &
            .Parent.SaveCopyAs chemin
            Application.DisplayAlerts = False
            With Workbooks.Open(chemin)
                With .Sheets("Feuil1").UsedRange
                    .Cells.AutoFilter
                    .AutoFilter 1, "<>*" & .Cells(i, 1).Value2, xlFilterValues
                    .Offset(1, 0).Rows.Delete
                    .Cells.AutoFilter
                End With
                .SaveAs chemin & ".xlsx", 51
                .Close True
            End With
            Application.DisplayAlerts = True
        End If
    Next i
End With
Application.ScreenUpdating = True

Salut, vois si ça peut t'aider:

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
Sub creer()
 
    ' Déclarer les variables
    Dim classeurOrigine As Workbook ' Référence au classeur d'origine
    Dim dossier As String ' Le dossier de destination
    Dim dico As Object ' Le dictionnaire pour stocker les valeurs uniques
    Dim plages As Range ' Les plages de cellules non vides
    Dim cellule As Range ' La cellule courante
    Dim chemin As String ' Le chemin du fichier à enregistrer
 
    ' Conserver la référence au classeur d'origine
    Set classeurOrigine = ThisWorkbook
 
    dossier = classeurOrigine.Path & "\" ' <<< adapter emplacement destination
    Set dico = CreateObject("Scripting.dictionary")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
 
    With classeurOrigine.Sheets(1)
        ' Sélectionner uniquement les cellules non vides de la colonne A
        Set plages = .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).SpecialCells(xlCellTypeConstants)
        For Each cellule In plages
            If Not dico.exists(cellule.Value2) Then
                dico(cellule.Value2) = ""
                chemin = dossier & cellule.Value2 ' <<< chemin (ADAPTER NOM FICHIER) "UR "
 
                ' Créer un nouveau classeur
                Dim nouveauClasseur As Workbook
                Set nouveauClasseur = Workbooks.Add
 
                ' Copier les données de la colonne A du classeur d'origine dans le nouveau classeur
                classeurOrigine.Sheets(1).Range("A:A").Copy Destination:=nouveauClasseur.Sheets(1).Range("A1")
 
                With nouveauClasseur.Sheets(1)
                    ' Supprimer les lignes en double
                    .Range("A:A").RemoveDuplicates Columns:=1, Header:=xlYes
                End With
 
                ' Enregistrer le nouveau classeur sous un autre nom et format
                nouveauClasseur.SaveAs chemin, 51
                nouveauClasseur.Close SaveChanges:=True
            End If
        Next cellule
    End With
 
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
 
    ' Revenir au classeur d'origine
    classeurOrigine.Activate
 
End Sub

02/06/2023, 08h10
android59

3 pièce(s) jointe(s)

Bonjour,
merci beaucoup, c'est presque cela, avec ce code, j'ai mes fichiers en fonction des lignes du fichier source mais il ne me reprend que la colonne A.

j'ai joints des fichiers excel pour illustrer ce que je souhaiterais faire .
Pièce jointe 639585

Pièce jointe 639586

Pièce jointe 639587

Pour chaque ligne, je souhaiterais créer un fichier avec pour nom la valeur en colonne A, là c'est bon, mais je reprends le contenu de toutes la ligne,après peut importe si je n'ai pas l'entete dans le fichier .
j'ai tenté de modifier le code mais je n'y arrive pas :(

Merci beaucoup

Ok, je comprends mieux maintenant, comme ceci alors:

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
Sub creer()
    ' Déclarer les variables
    Dim classeurOrigine As Workbook ' Référence au classeur d'origine
    Dim dossier As String ' Le dossier de destination
    Dim dico As Object ' Le dictionnaire pour stocker les valeurs uniques
    Dim plages As Range ' Les plages de cellules non vides
    Dim cellule As Range ' La cellule courante
    Dim chemin As String ' Le chemin du fichier à enregistrer
 
    ' Conserver la référence au classeur d'origine
    Set classeurOrigine = ThisWorkbook
 
    dossier = classeurOrigine.Path & "\" ' <<< adapter emplacement destination
    Set dico = CreateObject("Scripting.dictionary")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
 
    With classeurOrigine.Sheets(1)
        ' Sélectionner uniquement les cellules non vides de la colonne A, à partir de la deuxième ligne
        Set plages = .Range("A2", .Cells(.Rows.Count, 1).End(xlUp)).SpecialCells(xlCellTypeConstants)
 
        For Each cellule In plages
            If Not dico.Exists(cellule.Value2) Then
                dico(cellule.Value2) = ""
                chemin = dossier & cellule.Value2 ' <<< chemin (ADAPTER NOM FICHIER) "UR "
 
                ' Créer un nouveau classeur
                Dim nouveauClasseur As Workbook
                Set nouveauClasseur = Workbooks.Add
 
                ' Copier les en-têtes dans la première ligne du nouveau fichier
                classeurOrigine.Sheets(1).Rows(1).Copy Destination:=nouveauClasseur.Sheets(1).Range("A1")
 
                ' Copier la ligne complète du classeur d'origine dans le nouveau classeur
                .Rows(cellule.Row).Copy Destination:=nouveauClasseur.Sheets(1).Range("A2")
 
                ' Ajuster la largeur de colonne des nouveaux fichiers créés
                nouveauClasseur.Sheets(1).Columns("A:Z").AutoFit
 
                ' Enregistrer le nouveau classeur sous un autre nom et format
                nouveauClasseur.SaveAs chemin, 51
                nouveauClasseur.Close SaveChanges:=True
            End If
        Next cellule
    End With
 
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
 
    ' Revenir au classeur d'origine
    classeurOrigine.Activate
 
    MsgBox "Traitement terminé!"
 
End Sub

05/06/2023, 16h28
android59

4 pièce(s) jointe(s)

Bonjour
j'ai essayé le code mais en fait ce n'est pas le résultat que je souhaite obtenir.
j'ai tenté de modifié le code mais j'ai un peu de mal en vba.

J'ai créé un fichier source, proche de la réalité pour vous montrer ce que je souhaite avoir :
Pièce jointe 639694

ce fichier comporte 8 lignes avec les entreprises 123456, 7891123 et 70708080.

le resultat final que je souhaite obtenir c'est d'avoir un fichier par entreprise :
Pièce jointe 639695

dans lequel j'ai la liste des salarié , exemple pour l'entreprise 123456 :
Pièce jointe 639697

ou l'entreprise 70708080
Pièce jointe 639698

le fichier source est asse zgros, c'est pour cela que je souhaite faire une macro, qui créerait un fichier excel, par entreprise et qui me reprendrait l'entete, avec toutes les lignes concernées, est ce possible?

un grand merci à toi en tout cas.

Voilà, j'obtiens la même chose que ta copie écran.
Comme tu précises que c'est un gros fichier, j'ai modifié la macro pour travailler avec des tableaux en mémoire pour plus de performance (environ 35% de gain)

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
Sub creer()
    ' Déclarer les variables
    Dim classeurOrigine As Workbook ' Référence au classeur d'origine
    Dim dossier As String ' Le dossier de destination
    Dim plages As Range ' Les plages de cellules non vides
    Dim cellule As Range ' La cellule courante
    Dim chemin As String ' Le chemin du fichier à enregistrer
 
 
    ' Conserver la référence au classeur d'origine
    Set classeurOrigine = ThisWorkbook
 
    dossier = classeurOrigine.Path & "\" ' <<< adapter emplacement destination
 
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.EnableEvents = False
 
    With classeurOrigine.Sheets(1)
        ' Sélectionner uniquement les cellules non vides de la colonne A, à partir de la deuxième ligne
        Set plages = .Range("A2", .Cells(.Rows.Count, 1).End(xlUp)).SpecialCells(xlCellTypeConstants)
 
        For Each cellule In plages
            chemin = dossier & cellule.Value2 ' <<< chemin (ADAPTER NOM FICHIER) "UR "
 
            ' Créer un nouveau classeur pour chaque valeur unique dans la colonne A
            Dim nouveauClasseur As Workbook
            Set nouveauClasseur = Workbooks.Add
 
            ' Copier les en-têtes dans le nouveau fichier
            classeurOrigine.Sheets(1).Range("A1:E1").Copy Destination:=nouveauClasseur.Sheets(1).Range("A1")
 
            ' Copier toutes les lignes correspondantes avec la même valeur dans le nouveau fichier
            Dim i As Long
            i = 2 ' Commencer à partir de la deuxième ligne du nouveau fichier
 
            Dim ligne As Range
 
            ' Utiliser un tableau pour stocker les données en mémoire avant de les écrire dans une feuille de calcul
            Dim donnees() As Variant
            ReDim donnees(1 To plages.Rows.Count, 1 To .Columns.Count)
            Dim j As Long
            For Each ligne In plages.Rows
                If ligne.Cells(1).Value2 = cellule.Value2 Then
                    For j = 1 To .Columns.Count
                        donnees(i - 1, j) = ligne.Cells(1, j).Value2
                    Next j
 
                    i = i + 1 ' Incrémenter le compteur de ligne du nouveau fichier
                End If
            Next ligne
 
            ' Écrire les données du tableau dans la feuille de calcul en une seule opération
            nouveauClasseur.Sheets(1).Range("A2").Resize(i - 2, .Columns.Count).Value2 = donnees
 
            ' Enregistrer le nouveau classeur sous le nom de la valeur unique dans la colonne A
            nouveauClasseur.SaveAs chemin, FileFormat:=xlOpenXMLWorkbook
            nouveauClasseur.Close SaveChanges:=True
        Next cellule
    End With
 
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Application.EnableEvents = True
 
    MsgBox "Traitement terminé !"
 
End Sub

06/06/2023, 08h10
android59

Merci beaucoup.
j'ai réalisé un test , avec un petit fichier, j'ai pris un morceau de mon gros fichier, afin de voir le rendu.

Je ne comprend pas ce qu'il fait, il me génère un fichier, pour la 1ère entreprise avec toutes les lignes qui lui correspond donc ça c'est ok , puis le traitement mouline et il ne continue pas le traitement, je vois un fichier tmp qui se forme dans mon dossier puis il disparait, le fichier tmp change de nom à chaque fois est ce normal?

est ce que c'est parce qu'il réfléchit ?
Merci ^
06/06/2023, 08h20
android59

Voici une capture d'écran de ce que j'ai, car j'ai suspendu le traitement :
Pièce jointe 639723

Comme vous l'avez précisé, le code met en mémoire le tableau, mais je sais pas si c'est ça qui bloque?

à la limite ,dans mon gros fichier, je peux faire un découpage , par équipe, j'ai une trentaine d'équipe, ça sera rapide pour moi, puis j'utiliserais la macro pour chaque fichier , pour découper le fichier par entreprise , je pense que ça sera plus simple, qu'en pensez vous?

Pouvez vous svp réadapter le code pour ne que l'on utilise pas la mémoire et que ça aille rapidement ? ( désolé je m'y connais pas trop est ce possible ) ?

Dans le message du 02/06/2023, 11h52, le code est bien ça allé rapidement, il me découpait mon fichier, mais je n'avais qu'une ligne par fichier entreprise, il ne manquait plus que le fait d'avoir toutes les lignes salariés par fichier ( et donc par entreprise) ;

En tout cas merci beaucoup ^
06/06/2023, 09h56
android59

J'ai l'impression qu'avec cette méthode , en mettant en mémoire le tableau, ça bug, le 1er fichier est créé mais pas les autres.

Au bout d'un moment, je stoppe le traitement car il ne fait plus rien.

Chez moi ça fonctionne parfaitement, je ne vois pas d'où peut venir le problème.
Voici la version qui copie directement dans le nouveau classeur ligne par ligne, ce sera forcément plus lent que la version avec tableau en mémoire mais elle fonctionne sans problème chez moi.

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
Sub creer()
 
    ' Déclarer les variables
    Dim classeurOrigine As Workbook ' Référence au classeur d'origine
    Dim dossier As String ' Le dossier de destination
    Dim plages As Range ' Les plages de cellules non vides
    Dim cellule As Range ' La cellule courante
    Dim chemin As String ' Le chemin du fichier à enregistrer
 
    ' Conserver la référence au classeur d'origine
    Set classeurOrigine = ThisWorkbook
 
    dossier = classeurOrigine.Path & "\" ' <<< adapter emplacement destination
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
 
    With classeurOrigine.Sheets(1)
        ' Sélectionner uniquement les cellules non vides de la colonne A, à partir de la deuxième ligne
        Set plages = .Range("A2", .Cells(.Rows.Count, 1).End(xlUp)).SpecialCells(xlCellTypeConstants)
 
        For Each cellule In plages
            chemin = dossier & cellule.Value2 ' <<< chemin (ADAPTER NOM FICHIER) "UR "
 
            ' Créer un nouveau classeur pour chaque valeur unique dans la colonne A
            Dim nouveauClasseur As Workbook
            Set nouveauClasseur = Workbooks.Add
 
            ' Copier les en-têtes dans le nouveau fichier
            classeurOrigine.Sheets(1).Range("A1:E1").Copy Destination:=nouveauClasseur.Sheets(1).Range("A1")
 
            ' Copier toutes les lignes correspondantes avec la même valeur dans le nouveau fichier
            Dim i As Long
            i = 2 ' Commencer à partir de la deuxième ligne du nouveau fichier
 
            Dim ligne As Range
            For Each ligne In plages.Rows
                If ligne.Cells(1).Value2 = cellule.Value2 Then
                    ligne.EntireRow.Copy Destination:=nouveauClasseur.Sheets(1).Range("A" & i)
                    i = i + 1 ' Incrémenter le compteur de ligne du nouveau fichier
                End If
            Next ligne
 
            ' Enregistrer le nouveau classeur sous le nom de la valeur unique dans la colonne A
            nouveauClasseur.SaveAs chemin, FileFormat:=xlOpenXMLWorkbook
            nouveauClasseur.Close SaveChanges:=True
        Next cellule
    End With
 
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
 
    ' Revenir au classeur d'origine
    classeurOrigine.Activate
 
    MsgBox "Traitement terminé !"
 
End Sub

08/06/2023, 08h26
android59

Bien le bonjour,
je suis en train de réaliser des tests, les premiers sont concluant*

J'ai tenté de lancer ma macro sur mon fros fichier, il m'a dit " mémoire insuffisante " ( lol) du coup j'ai fais comme j'ai dis, j'ai decoupé mon fichier par equipe et je vois si ça marche , merci ^
12/06/2023, 14h55
android59

Franc Bonjour,

un grand merci à toi, le code marche super bien :)