Aide VBA - Dupliquer Onglets via un tableau structuré

Bonjour à tous !

Je suis en train de travailler sur un tableau à destination d'un groupe de travail qui devra renseigner des informations pour chacun des clients.

A cet effet, je souhaite dupliquer un onglet ("Modèle") du tableau ci-joint afin d'en créer un pour chaque client. J'ai déjà trouvé des bouts de code qui permettent de dupliquer les onglets mais étant encore novice en la matière, je n'arrive pas bien à l'adapter à mon cas.

En effet, lorsque je regarde les macros proposées, la liste qui permet de renommer chaque onglet dupliqué se trouve dans une plage de type A:A avec quelque chose du style .End(xlUp).Row (ce qui à mon sens permet d'aller jusqu'au bout des lignes). Cependant avec mon fichier je ne souhaite pas cibler une colonne (A, B...) qui risquerai de contenir d'autres données. Je souhaite simplement utiliser les plages renommées (NumClient, NomClient..) afin d'être certain de ne prendre que les bonnes données.

Voici le code que j'ai trouvé mais qui pour l'instant "bug" à chaque modification de ma part.

Public Function FeuilleExiste(FeuilleAVerifier As String) As Boolean

On Error GoTo SiErreur
Dim Feuille As Worksheet

    FeuilleExiste = False
    For Each Feuille In Worksheets
        If Feuille.Name = FeuilleAVerifier Then
            FeuilleExiste = True
            Exit Function
        End If
    Next Feuille
Exit Function

SiErreur:
MsgBox "Une erreur s'est produite..."
FeuilleExiste = CVErr(xlErrNA)
End Function
Sub dupliquer()
Dim nom As String
Set Ws = Worksheets("Sommaire")
    nbcc = Ws.Range("D1").Value
    For I = 1 To Ws.Range("NumSoc").End(xlUp).Row
        nom = Ws.Range("NumSoc").Value
        If FeuilleExiste(nom) = False Then
            Sheets("Modèle").Copy After:=Sheets(Sheets.Count)
            ActiveSheet.Name = nom

        End If
    Next
End Sub

Ca serait top si quelqu'un pouvait m'indiquer ce que je dois changer/déclarer/modifier afin que cela fonctionne.

D'avance merci !

Sam

Bonjour,

Un proposition https://www.excel-pratique.com/fr/telechargements/utilitaires/dispatcher-compiler-excel-no466 qui te permettra de scinder ton fichier en autant de fichier qu'il y a de valeurs différente dans une colonne quelconque. En retour il te permettra aussi de collecter les fichiers renseignés.

Bonjour Steelson,

Merci pour ta réponse. Etant novice je t'avoue que le code me file un peu le tournis

Après, le but était vraiment de pouvoir dupliquer l'onglet "Modèle" dans le même tableau en lui attribuant juste un nom différent (cf. la liste des numéros client)

Mais je garde tout de même ta proposition pour mon acculturation et un éventuel futur projet. Cela m'aide beaucoup de décortiquer les différentes propositions des uns et des autres.

Du coup si quelqu'un à une solution, je suis toujours preneur ^^

J'ai répondu un peu vite ... j'ai compris que tu voulais dupliquer des fiches.

Donc voici un premier jet vite fait ... je vais l'améliorer d'ici demain mais il est déjà fonctionnel. Un fichier est créé par client. Il faut juste choisir le répertoire dans lequel stocker ces fichiers.

Sub creerfiches()
    Dim bdd As Worksheet
    Dim fiche As Worksheet

    ' définitions pour fichier cible
    Dim xl As Excel.Application
    Dim wb As Excel.Workbook
    Dim ws As Excel.Worksheet

    Set bdd = Sheets("BDD")
    Set fiche = Sheets("Modèle")

    Set Repertoire = Application.FileDialog(msoFileDialogFolderPicker)
    Application.FileDialog(msoFileDialogFolderPicker).Title = "Choix du répertoire de stockage des fichiers générés"
    Repertoire.Show
    If Repertoire.SelectedItems.Count = 0 Then Exit Sub
    MonRepertoire = Repertoire.SelectedItems(1)
    'Application.ScreenUpdating = false

    Set xl = CreateObject("Excel.Application")
    xl.SheetsInNewWorkbook = 1 ' On défini le nombre d'onglets (ici 1 seul)

    For i = 5 To bdd.Cells(Rows.Count, 2).End(xlUp).Row
        For j = 2 To 4
            fiche.Range(bdd.Cells(1, j)) = bdd.Cells(i, j)
        Next
        fiche.Cells.Copy
        Set wb = xl.Workbooks.Add  ' On ajoute un classeur
        xl.Visible = True
        Set ws = wb.Worksheets(1)  ' On crée l'objet onglet dans le nouveau classeur créé
        Application.Wait (Now + TimeValue("0:00:02"))
        ws.Paste
        ' sauvegared du fichier
        wb.SaveAs (MonRepertoire & "\" & bdd.Cells(i, 2) & " " & Format(Now(), "yyyy-mm-dd") & " " & nomFichier)

    Next

    'xl.SheetsInNewWorkbook = 3 ' On remet la propriété de l'application à 3 (par défaut)
    xl.Quit
    'Application.ScreenUpdating = True

    MsgBox "Terminé, fiches sauvegardées sous """ & MonRepertoire & "\" & """ !"

End Sub
13creer-fiches.xlsm (21.32 Ko)

Haha ! Effectivement tu codes bien au delà de mes connaissances ^^ Et ça a l'air super !

Si tu comptes revoir le code pourrais-tu faire en sorte que l'onglet "Modèle" soit dupliqué et renommé (autant de fois que nécessaire) à la suite des autres ? Plutôt que de proposer un enregistrement de chaque onglet comme un nouveau classeur ?

L'idée en fait (c'est ptet moi qui ne m'exprime pas bien ^^) serait de dupliquer "Modèle" en fonction de la liste des clients présente dans le tableau de l'onglet "BDD". Et éventuellement (et là ça serait du luxe) rapatrier le nom et le numéro dans chaque onglet créé.

En tout cas, merci pour ta réactivité et ton aide qui me font, j'en suis sur, progresser dans ma compréhension de ces fonctions.

A plus.

Sam

Pas de soucis (je ferai les 2 car je pense que la duplication sur des fichiers séparés est utile quand on envoie ensuite par mail un questionnaire).

Dupliquer l'onglet est plus simple !

Sub creerfiches()
    Dim bdd As Worksheet, modele As Worksheet, fiche As Worksheet, tbl As ListObject
    Set bdd = Sheets("BDD")
    Set modele = Sheets("Modèle")
    Set tbl = bdd.ListObjects(1)
    col = tbl.DataBodyRange.Cells(1, 1).Column ' position du tableau de données

    For i = 1 To tbl.ListRows.Count
        modele.Cells.Copy
        Set fiche = Sheets.Add(After:=Sheets(Sheets.Count))
        fiche.Paste
        On Error Resume Next ' au cas où la fiche existerait déjà !
            fiche.Name = tbl.DataBodyRange.Cells(i, 1)
        On Error GoTo 0
        For j = 1 To tbl.ListColumns.Count
            ' position dans la fiche donnée en ligne 1 de bdd
            If bdd.Cells(1, j + col - 1) <> "" Then fiche.Range(bdd.Cells(1, j + col - 1)) = tbl.DataBodyRange.Cells(i, j)
        Next
    Next

    MsgBox "Terminé !"

End Sub

La position des données dans la fiche est donnée en première ligne au-dessus du tableau.

Bonjour,

@Steelson,

Ma vision matinale de la chose.

Public Sub CreateSheets()
Dim lo As ListObject, ws As Worksheet
Dim arrValues, sheetName As String
Dim I As Long
    Set lo = Range("T_BDD").ListObject
    For I = 1 To lo.ListRows.Count
        sheetName = lo.ListRows(I).Range.Cells(1).Value
        On Error Resume Next
        Set ws = Worksheets(sheetName)
        On Error GoTo 0
        If ws Is Nothing Then
            arrValues = lo.ListRows(I).Range.Value
            With Worksheets("Modèle")
                .Cells(4, 3).Resize(3).Value = Application.Transpose(arrValues)
                .Copy after:=Worksheets(Worksheets.Count)
            End With
            ActiveSheet.Name = sheetName
        End If
    Next
    Worksheets("Modèle").Cells(4, 3).Resize(3).Value = ""
    Worksheets(lo.Parent.Name).Activate
End Sub

Cdlt.

Bonjour Jean-Eric,

  1. je voulais pour ma part paramétrer les données et les "ranger" dans la fiche selon un ordre qui peut-être défini au préalable, sans forcément en reprendre tous les termes de la BdD
  2. dans tous les cas, je suis plus "axé" vers une solution multi-fichiers qui peut être envoyée comme un questionnaire pré-rempli, ce que je mettrai dans les applications (c'était un sujet que je mijotais)

Bien sûr ta version est très intéressante.

Bonjour à tous les deux !

J'ai vraiment de la chance, vos réponses rapides sont d'une qualité remarquable. Ca fait plaisir quand on débute de pouvoir être aidé de la sorte.

Je cherchais désespérément à "appeler" le tableau créé sur la feuille BDD et à en utiliser les lignes. C'était la partie lo et .ListObject qui me manquait pour exploiter ma base. Merci pour ça. J'avoue qu'il va me falloir encore comprendre une partie de ce que vous avez écrit pour que je puisse le refaire par moi-même la prochaine fois, mais ça, c'est mon problème ^^ (et les commentaires aident déjà)

Je suis toujours preneur (à vos heures perdues, aucune urgence ici) d'une version qui pourrait créer des fichiers distincts comme propose @Steelson. Sur ce document il n'y avait pas une forte utilité car je le transmet à une personne d'un autre service qui aura plus facile de travailler sur le même classeur mais j'ai déjà eu des demandes où je dois être en capacité de produire un classeur par "fiche" et ce projet me ferait gagner un temps considérable.

Du coup encore merci de votre aide, vous êtes au top !

Sam

Version fichiers distincts

Option Explicit

Sub creerfiches()
    Dim bdd As Worksheet, modele As Worksheet, fiche As Worksheet, tbl As ListObject, i%, j%, col%
    Dim Repertoire, monRepertoire As Variant
    Set bdd = Sheets("BDD")
    Set modele = Sheets("Modèle")
    Set tbl = bdd.ListObjects(1)
    col = tbl.DataBodyRange.Cells(1, 1).Column ' position du tableau de données
    ' définitions pour fichier cible
    Dim xl As Excel.Application, wb As Workbook, ws As Worksheet

    ' choix du répertoire de stockage
    Set Repertoire = Application.FileDialog(msoFileDialogFolderPicker)
    Application.FileDialog(msoFileDialogFolderPicker).Title = "Choix du répertoire de stockage des fichiers générés"
    Repertoire.Show
    If Repertoire.SelectedItems.Count = 0 Then Exit Sub
    monRepertoire = Repertoire.SelectedItems(1)

    Set xl = CreateObject("Excel.Application")

    For i = 1 To tbl.ListRows.Count
        For j = 1 To tbl.ListColumns.Count
            ' position dans la fiche donnée en ligne 1 de bdd
            If bdd.Cells(1, j + col - 1) <> "" Then modele.Range(bdd.Cells(1, j + col - 1)) = tbl.DataBodyRange.Cells(i, j)
        Next
        modele.Cells.Copy
        Set wb = xl.Workbooks.Add  ' On ajoute un classeur
        xl.Visible = True
        Set ws = wb.Worksheets(1)  ' On crée l'objet onglet dans le nouveau classeur créé
        Application.Wait (Now + TimeValue("0:00:02"))
        ws.Paste
        ' sauvegarde du fichier
        wb.SaveAs (monRepertoire & "\" & tbl.DataBodyRange.Cells(i, 1))
    Next
    xl.Quit
    Application.CutCopyMode = False

    MsgBox "Terminé, fiches sauvegardées sous """ & monRepertoire & "\" & """ !"

End Sub
14creer-fiches.xlsm (21.81 Ko)

Version qui permet de mieux contrôler la mise en forme des fiches générées ...

Il faut mettre un modèle appelé Fiches.xlsx dans le même dossier que le fichier comportant la base de données.

Option Explicit

Sub creerfiches()
    Dim bdd As Worksheet, fiche As Worksheet, tbl As ListObject, i%, j%, col%, wb As Workbook
    Dim Repertoire, monRepertoire As Variant
    Set bdd = Sheets("BDD")
    Set tbl = bdd.ListObjects(1)
    col = tbl.DataBodyRange.Cells(1, 1).Column ' position du tableau de données

    ' choix du répertoire de stockage
    Set Repertoire = Application.FileDialog(msoFileDialogFolderPicker)
    Application.FileDialog(msoFileDialogFolderPicker).Title = "Choix du répertoire de stockage des fichiers générés"
    Repertoire.Show
    If Repertoire.SelectedItems.Count = 0 Then Exit Sub
    monRepertoire = Repertoire.SelectedItems(1)

    Application.ScreenUpdating = False
    For i = 1 To tbl.ListRows.Count
        Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & "Fiche.xlsx")
        Set fiche = wb.Sheets(1)
        For j = 1 To tbl.ListColumns.Count
            ' position dans la fiche donnée en ligne 1 de bdd
            If bdd.Cells(1, j + col - 1) <> "" Then fiche.Range(bdd.Cells(1, j + col - 1)) = tbl.DataBodyRange.Cells(i, j)
        Next
        wb.SaveAs (monRepertoire & "\" & tbl.DataBodyRange.Cells(i, 1))
        wb.Close
        Set wb = Nothing
    Next
    Application.ScreenUpdating = True

    MsgBox "Terminé, fiches sauvegardées sous """ & monRepertoire & "\" & """ !"

End Sub
57creer-fiches.xlsm (20.72 Ko)
42fiche.xlsx (10.21 Ko)

Bonjour @Steelson

Eh ben, si avec tout ça je n'ai pas de quoi réaliser mon projet ^^

Merci pour tout le travail fourni, c'est hyper appréciable ! Et j'avoue que l'idée de bosser avec un modèle a part semble ouvrir encore plus le champ des possibles.

Je pense que je peux clore le sujet.

Rechercher des sujets similaires à "aide vba dupliquer onglets via tableau structure"