Créer des fichiers Excel à partir d'une liste de personnes

Bonsoir,

D'avance un gros merci à ceux qui prendront un peu de temps pour m'aider.

J'ai un fichier contenant trois onglets :

• Onglet LISTE : Un tableau contenant une liste de personnes avec des caractéristiques

• Onglet FICHE : Une fiche qui présente de façon plus sympa les infos pour chaque personne. Les champs pointe vers une cellule (H1) qui contient la liste des personnes de l'onglet "LISTE".

• Onglet INUTILE : Il existe dans le fichier mais en sert à rien à ce moment des opérations.

J'ai besoin de créer pour chacune des personnes contenues dans le tableau de l'onglet liste un fichier Excel avec un seul onglet ("FICHE") contenant les données qui leur sont relatives.

J'ai créé une macro qui réussit à créer les fichiers en question et en les renommant d'une manière précise (il suffit de cliquer sur le bouton CREATION dans l'onglet LISTE.

Sub Création_fichiers_nominatifs() ' ' Creation des fichiers nominatifs Sheets("LISTE").Select Range("A5").Select Selection.Copy Sheets("FICHE").Select Range("H1").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Dim Liste As String, C As Range With Sheets("FICHE") Liste = .Range("H1").Validation.Formula1 Liste = Right(Liste, Len(Liste) - 1) For Each C In Range(Liste) .[H1] = C.Value If Dir(ThisWorkbook.Path & "\" & "FICHE_" & [B4].Value & "_" & Format(Date, "yyyy-mm-dd")) = "" Then GoTo Move_on Else GoTo Test_exit End If Test_exit: MsgBox ("Un fichier portant le même nom a déjà été sauvegardé à cet emplacement. Merci de le supprimer avant d'imprimer cette fiche.") Exit Sub Move_on: ActiveWorkbook.SaveAs Filename:= _ ThisWorkbook.Path & "\" & "Fiche People_" & [B4].Value & "_" & Format(Date, "yyyy-mm-dd") MsgBox ("La fiche a bien été générée.") Next C End With End Sub

Cependant, j'ai un souci, avant d'enregistrer chacun des fichiers pour chaque personne, j'aimerais que la macro fasse trois actions :

• supprimer l'onglet "INUTILE" qui ne me sert pas à cet endroit ;

• copier-coller les valeurs contenues dans l'onglet "FICHE" ;

• supprimer l'onglet "LISTE" afin que la liste intégrale des personnes ne soit pas contenue dans chaque fichier individuel.

J'ai essayé plusieurs manips (voir code ci-dessous) mais je n'arrive pas à le faire. Il est probable que je n'insère pas certaines instructions au bon endroit dans la macro. Du coup, pensez-vous qu'il s'agisse d'un problème de positionnement de ces instructions supplémentaires ou bien faudrait-il construire la macro qui crée les fichiers autrement (auquel cas, je suis complètement dépassé) afin de pouvoir résoudre mon souci ?

Sheets("FICHE").Select Cells.Select Selection.Copy Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Range("A1").Select Application.CutCopyMode = False Sheets("INUTILE").Select ActiveWindow.SelectedSheets.Delete Sheets("LISTE").Select ActiveWindow.SelectedSheets.Delete

Désolé. Je suis pas un pro.

J'ai uploadé un fichier avec des données bidons pour que vous puissiez mieux visualiser mon problème.

Encore merci.

Bonjour,

Un début de réponse.

Un fichier existant est écrasé lors de l'enregistrement !...

Cdlt.

Public Sub Create_files()
Dim wb As Workbook
Dim ws As Worksheet, ws2 As Worksheet
Dim rng As Range, Cell As Range
Dim sPath As String, sFile As String

    Set wb = ActiveWorkbook
    sPath = wb.Path & Application.PathSeparator
    Set ws = wb.Worksheets("LISTE")
    Set rng = ws.ListObjects(1).ListColumns(1).DataBodyRange
    Set ws2 = wb.Worksheets("FICHE")

    For Each Cell In rng
        ws2.Cells(8).Value = Cell.Value
        ws2.Copy
        With ActiveWorkbook
            With .Worksheets(1)
                .Name = Cell.Value
                .UsedRange.Value = .UsedRange.Value
                .Cells(8).Validation.Delete
            End With
            Application.DisplayAlerts = False
            sFile = "Fiche_" & Cell.Value & Format(Date, "_yyyymmdd")
            .SaveAs sPath & sFile, 51
            .Close False
        End With
    Next Cell

End Sub

Génial. Je regarde ça pendant la sieste de mon p'tit loup.

Flûte. J'ai un message d'erreur "L'indice n'appartient pas à la sélection". Cela semble être cette ligne qui bloque :

Set rng = ws.ListObjects(1).ListColumns(1).DataBodyRange

Je ne vois pas du tout quoi modifier.

Re,

Je pensais avoir le classeur !...

Tu dois mettre les données sous forme de tableau.

Sélectionne la cellule A4 ; Ctrl + L; Cocher mon tableau comporte des en-têtes.

Valider, enregistrer le classeur et lancer la procédure.

Cdlt.

C'est top ! Ça fonctionne nickel. Un grand merci !

Bon désolé, en fait, j'ai une question complémentaire.

En fait, dans mon fichier, je vais être obligé d'avoir deux autres onglets (qui eux sont utiles) et qu'il faudrait que je garde dans mes fichiers individuels une fois créés. Je n'arrive pas à repérer dans la macro comment on fait pour copier deux feuilles au lieu d'une seule dans les nouveaux fichiers.

J'ai essayé de faire un test en ajoutant une feuille "UTILE 1" que j'ai défini comme ws3 dans la macro, puis de l'insérer aux endroits qui me paraissaient opportuns. Evidemment, ça ne fonctionne pas.

Public Sub Create_files()

Dim wb As Workbook

Dim ws As Worksheet, ws2 As Worksheet, ws3 As Worksheet

Dim rng As Range, Cell As Range

Dim sPath As String, sFile As String

Set wb = ActiveWorkbook

sPath = wb.Path & Application.PathSeparator

Set ws = wb.Worksheets("LISTE")

Set rng = ws.ListObjects(1).ListColumns(1).DataBodyRange

Set ws2 = wb.Worksheets("FICHE")

Set ws3 = wb.Worksheets("UTILE 1")

For Each Cell In rng

ws2.Cells(8).Value = Cell.Value

Sheets(Array(ws2, ws3)).Copy

With ActiveWorkbook

With .Worksheets(1)

.Name = Cell.Value

.UsedRange.Value = .UsedRange.Value

.Cells(8).Validation.Delete

End With

Application.DisplayAlerts = False

sFile = "Fiche_" & Cell.Value & Format(Date, "_yyyymmdd")

.SaveAs sPath & sFile, 51

.Close False

End With

Next Cell

End Sub

Bonjour,

Essaie ainsi (exemple).

Cdlt.

Option Explicit

Public Sub Create_files()
Dim wb As Workbook
Dim ws As Worksheet
Dim rng As Range, Cell As Range
Dim sPath As String, sFile As String

    Application.ScreenUpdating = False

    Set wb = ActiveWorkbook
    sPath = wb.Path & Application.PathSeparator
    Set ws = wb.Worksheets("LISTE")
    Set rng = ws.ListObjects(1).ListColumns(1).DataBodyRange

    For Each Cell In rng
        wb.Worksheets("FICHE").Cells(8).Value = Cell.Value
        wb.Sheets(Array("FICHE", "INUTILE")).Copy
        With ActiveWorkbook
            With .Worksheets(1)
                .Name = Cell.Value
                .UsedRange.Value = .UsedRange.Value
                .Cells(8).Validation.Delete
            End With
            Application.DisplayAlerts = False
            sFile = "Fiche_" & Cell.Value & Format(Date, "_yyyymmdd")
            .SaveAs sPath & sFile, 51
            .Close False
        End With
    Next Cell

End Sub

Top ! Top ! Top ! Encore un grand merci.

Bon, jamais deux sans trois. Promis après j'arrête.

J'ai hésité à créer un autre sujet ou continuer sur celui-ci (puisque je suis dans la continuité de mon fichier). N'hésitez pas à me dire.

En fait, j'aimerais bien que la macro masque un onglet dans chaque fichier individuel au cours de la manip.

J'ai essayé d'insérer des bouts de code dans la macro (qui fonctionne bien pour tout le reste), mais ça ne fonctionne pas.

J'ai aussi essayé de faire une macro séparée qui me demanderait le nom du répertoire où sont localisés mes fichiers individuels, puis qui les ouvrent un par un et masque l'onglet en question avant de les enregistrer. J'ai farfouillé sur le forum, mais j'ai eu beau mélanger du code, ça ne donne rien. Je copie mon code Frankenstein (désolé, ça doit vraiment piquer les yeux quand on est un pro mais j'ai essayé) ci-dessous :

Sub Masquer_feuilles()

Dim Wb As Workbook

Dim sPath As String

Dim Fichier As String

Set Wb = ActiveWorkbook

sPath = Wb.Path & Application.PathSeparator

With Application.FileDialog(msoFileDialogFolderPicker)

.InitialFileName = ActiveWorkbook.Path & "\"

.Show

Wb = Dir(sPath & "*.xls*")

Do While Len(Fichier) > 0

Sheets("INUTILE").Select

ActiveWindow.SelectedSheets.Visible = False

Sheets("LISTE").Select

Wb.SaveCopyAs sPath & Fichier

Wb.Close False

Fichier = Dir()

Loop

End Sub

Du coup, je ne sais pas s'il y a un moyen tout simple de le faire directement dans la première macro (ce qui éviterait de faire deux manips) ou sinon de faire la petite macro à part (c'est pas la mort non plus).

Merci beaucoup !