Créer un fichier par ligne

[marjo06]

Bonjour,
Est-il possible à partir d'un tableau contenant 400 lignes d'extraire chacune d'elles et d'en faire un fichier unique ? Concrètement j'ai 400 adhérents sur un même tableau avec toutes leurs données respectives et j'aimerais avoir un fichier par adhérent. Je sais pas si je suis claire !
Merci. Bonne journée.

 

[Minick]

Re : Créer un fichier par ligne

Regarde la variable NumAsso que j'ai ajouter (pour le format)

 

[marjo06]

Re : Créer un fichier par ligne

Impec !
Merci merci merci !!
Bonne journée.

 

[pifpafpouf]

Re : Créer un fichier par ligne

Bonjour à tous,

J'ai voulu utiliser le travail (merveilleux) fait par Minick mais en modifiant le code car mes fichiers sont sous Excel 2010.
Lorsque je lance la macro elle tourne mais aucun classeur ne se génère dans le dossier. Y'a-t-il des modifications supplémentaires à apporter ? Merci d'avance

Option Explicit

Sub Export()
    Dim Cellule As Range
    Dim WkbSrc As Workbook, WkbDst As Workbook
    Dim ShtSrc As Worksheet, ShtDst As Worksheet
    
    Application.ScreenUpdating = False
        If Dir(ThisWorkbook.Path & "\listing.xlsx") = "" Then
            MsgBox "Le fichier 'listing' (listing.xlsx) est introuvable.", vbOKOnly
        Else
            If Dir(ThisWorkbook.Path & "\grille.xlsx") = "" Then
                MsgBox "Le fichier 'Modele' (grille.xlsx) est introuvable.", vbOKOnly
            Else
                Set WkbSrc = Workbooks.Open(Filename:=ThisWorkbook.Path & "\listing.xlsx")
                Set ShtSrc = WkbSrc.Sheets(1)
                
                For Each Cellule In ShtSrc.Range("N2:N" & ShtSrc.Range("N65536").End(xlUp).Row)
                    If Dir(ThisWorkbook.Path & "\" & Cellule.Value & ".xlsx") = "" Then
                        Set WkbDst = Workbooks.Open(Filename:=ThisWorkbook.Path & "\grille.xlsx")
                    Else
                        Set WkbDst = Workbooks.Open(Filename:=ThisWorkbook.Path & "\" & Cellule.Value & ".xlsx")
                    End If
                    
                    Set ShtDst = WkbDst.Worksheets("Grille")
                        
                    ShtDst.Range("C5").Value = ShtSrc.Range("L" & Cellule.Row).Value
                    ShtDst.Range("C7").Value = ShtSrc.Range("B" & Cellule.Row).Value
                    ShtDst.Range("C9").Value = ShtSrc.Range("J" & Cellule.Row).Value
                    ShtDst.Range("G5").Value = ShtSrc.Range("E" & Cellule.Row).Value
                    ShtDst.Range("G7").Value = ShtSrc.Range("F" & Cellule.Row).Value
                               
                    
                    If WkbDst.Name = "grille.xlsx" Then
                        WkbDst.Close savechanges:=True, Filename:=ThisWorkbook.Path & "\" & Cellule.Value & ".xlsx"
                    Else
                        WkbDst.Close savechanges:=True
                    End If
                Next Cellule
                
                WkbSrc.Close savechanges:=False
                
                Set ShtSrc = Nothing
                Set WkbSrc = Nothing
                Set ShtDst = Nothing
                Set WkbDst = Nothing
            End If
        End If
    Application.ScreenUpdating = True
End Sub